public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-2011] [Ada] Add Ada 2022 Image and Put_Image support for tagged types
@ 2021-07-05 13:13 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-07-05 13:13 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:b4b023c4267801dce118923421124e0d9f65075f
commit r12-2011-gb4b023c4267801dce118923421124e0d9f65075f
Author: Steve Baird <baird@adacore.com>
Date: Fri Apr 16 16:07:31 2021 -0700
[Ada] Add Ada 2022 Image and Put_Image support for tagged types
gcc/ada/
* debug.adb: Remove comments about -gnatd_z switch.
* exp_ch3.adb (Make_Predefined_Primitive_Specs): A one-line fix
for a subtle bug that took some effort to debug. Append a new
Put_Image procedure for a type extension even if it seems to
already have one, just as is done for (for example) the
streaming-related Read procedure.
* exp_put_image.adb:
(Build_Record_Put_Image_Procedure.Make_Component_Attributes): Do
not treat _Parent component like just another component, for two
reasons. 1. If the _parent component's type has a
user-specified Put_Image procedure, then we want to generate a
call to that procedure and then generate extension aggregate
syntax. 2. Otherwise, we still don't want to see any mention of
"_parent" in the generated image text.
(Build_Record_Put_Image_Procedure.Make_Component_Name): Add
assertion that we are not generating a reference to an "_parent"
component.
(Build_Record_Put_Image_Procedure): Add special treatment for
null records. Add call to Duplicate_Subexpr for image attribute
prefix in order to help with expansion needed in the class-wide
case (where the prefix is also referenced in the call to
Wide_Wide_Expanded_Name) if evaluation of the prefix has side
effects. Add new local helper function, Put_String_Exp. Add
support for case where prefix type is class-wide.
(Enable_Put_Image, Preload_Root_Buffer_Type): Query Ada_Version
> Ada_2022 instead of (indirectly) querying -gnatd_z switch.
* freeze.adb (In_Expanded_Body): A one-line change to add
TSS_Put_Image to the list of subprograms that have
expander-created bodies.
* rtsfind.ads: Add support for accessing
Ada.Tags.Wide_Wide_Expanded_Name.
* sem_ch3.ads, sem_ch3.adb: Delete Is_Null_Extension function,
as part of moving it to Sem_Util.
* sem_ch13.adb
(Analyze_Put_Image_TSS_Definition.Has_Good_Profile): Improve
diagnostic messages in cases where the result is going to be
False and the Report parameter is True. Relax overly-restrictive
checks in order to implement mode conformance.
(Analyze_Stream_TSS_Definition.Has_Good_Profile): Add similar
relaxation of parameter subtype checking for the Stream
parameter of user-defined streaming subprograms.
* sem_disp.adb (Check_Dispatching_Operation): A one-line
change (and an accompanying comment change) to add TSS_Put_Image
to the list of compiler-generated dispatching primitive
operations.
* sem_util.ads, sem_util.adb: Add Ignore_Privacy Boolean
parameter to Is_Null_Record_Type function (typically the
parameter will be False when the function is being used in the
implementation of static semantics and True for dynamic
semantics; the parameter might make a difference in the case of,
for example, a private type that is implemented as a null record
type). Add related new routines Is_Null_Extension (formerly
declared in Sem_Ch3), Is_Null_Extension_Of, and
Is_Null_Record_Definition.
Diff:
---
gcc/ada/debug.adb | 5 +-
gcc/ada/exp_ch3.adb | 4 +-
gcc/ada/exp_put_image.adb | 286 ++++++++++++++++++++++++++++++++++++----------
gcc/ada/freeze.adb | 1 +
gcc/ada/rtsfind.ads | 2 +
gcc/ada/sem_ch13.adb | 54 ++++++---
gcc/ada/sem_ch3.adb | 50 --------
gcc/ada/sem_ch3.ads | 5 -
gcc/ada/sem_disp.adb | 4 +-
gcc/ada/sem_util.adb | 143 +++++++++++++++++++++--
gcc/ada/sem_util.ads | 25 +++-
11 files changed, 425 insertions(+), 154 deletions(-)
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 3f1fa55932a..978f333e9cc 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -164,7 +164,7 @@ package body Debug is
-- d_w
-- d_x Disable inline expansion of Image attribute for enumeration types
-- d_y
- -- d_z Enable Put_Image on tagged types
+ -- d_z
-- d_A Stop generation of ALI file
-- d_B Warn on build-in-place function calls
@@ -993,9 +993,6 @@ package body Debug is
-- d_x The compiler does not expand in line the Image attribute for user-
-- defined enumeration types and the standard boolean type.
- -- d_z Enable the default Put_Image on tagged types that are not
- -- predefined.
-
-- d_A Do not generate ALI files by setting Opt.Disable_ALI_File.
-- d_B Warn on build-in-place function calls. This allows users to
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 4dbaadd637d..ce6d294e923 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -10345,9 +10345,7 @@ package body Exp_Ch3 is
-- Spec of Put_Image
- if Enable_Put_Image (Tag_Typ)
- and then No (TSS (Tag_Typ, TSS_Put_Image))
- then
+ if Enable_Put_Image (Tag_Typ) then
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image),
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 33c72c3fad0..3a9751b574d 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -23,13 +23,14 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
+with Csets; use Csets;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Exp_Tss; use Exp_Tss;
-with Exp_Util;
-with Debug; use Debug;
+with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -49,9 +50,6 @@ with Uintp; use Uintp;
package body Exp_Put_Image is
- Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z;
- -- ???Set True to enable Put_Image for at least some tagged types
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -649,32 +647,90 @@ package body Exp_Put_Image is
-- Loop through components, skipping all internal components,
-- which are not part of the value (e.g. _Tag), except that we
-- don't skip the _Parent, since we do want to process that
- -- recursively. If _Parent is an interface type, being abstract
- -- with no components there is no need to handle it.
+ -- recursively.
while Present (Item) loop
if Nkind (Item) in
N_Component_Declaration | N_Discriminant_Specification
- and then
- ((Chars (Defining_Identifier (Item)) = Name_uParent
- and then not Is_Interface
- (Etype (Defining_Identifier (Item))))
- or else
- not Is_Internal_Name (Chars (Defining_Identifier (Item))))
then
- if First_Time then
- First_Time := False;
- else
- Append_To (Result,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Record_Between), Loc),
- Parameter_Associations => New_List
- (Make_Identifier (Loc, Name_S))));
+ if Chars (Defining_Identifier (Item)) = Name_uParent then
+ declare
+ Parent_Type : constant Entity_Id :=
+ Underlying_Type (Base_Type (
+ (Etype (Defining_Identifier (Item)))));
+
+ Parent_Aspect_Spec : constant Node_Id :=
+ Find_Aspect (Parent_Type, Aspect_Put_Image);
+
+ Parent_Type_Decl : constant Node_Id :=
+ Declaration_Node (Parent_Type);
+
+ Parent_Rdef : Node_Id :=
+ Type_Definition (Parent_Type_Decl);
+ begin
+ -- If parent type has an noninherited
+ -- explicitly-specified Put_Image aspect spec, then
+ -- display parent part by calling specified procedure,
+ -- and then use extension-aggregate syntax for the
+ -- remaining components as per RM 4.10(15/5);
+ -- otherwise, "look through" the parent component
+ -- to its components - we don't want the image text
+ -- to include mention of an "_parent" component.
+
+ if Present (Parent_Aspect_Spec) and then
+ Entity (Parent_Aspect_Spec) = Parent_Type
+ then
+ Append_Component_Attr
+ (Result, Defining_Identifier (Item));
+
+ -- Omit the " with " if no subsequent components.
+
+ if not Is_Null_Extension_Of
+ (Descendant => Typ,
+ Ancestor => Parent_Type)
+ then
+ Append_To (Result,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Put_UTF_8), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S),
+ Make_String_Literal (Loc, " with "))));
+ end if;
+ else
+ if Nkind (Parent_Rdef) = N_Derived_Type_Definition
+ then
+ Parent_Rdef :=
+ Record_Extension_Part (Parent_Rdef);
+ end if;
+
+ if Present (Component_List (Parent_Rdef)) then
+ Append_List_To (Result,
+ Make_Component_List_Attributes
+ (Component_List (Parent_Rdef)));
+ end if;
+ end if;
+ end;
+
+ elsif not Is_Internal_Name
+ (Chars (Defining_Identifier (Item)))
+ then
+ if First_Time then
+ First_Time := False;
+ else
+ Append_To (Result,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Record_Between), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
+ end if;
+
+ Append_To (Result, Make_Component_Name (Item));
+ Append_Component_Attr
+ (Result, Defining_Identifier (Item));
end if;
-
- Append_To (Result, Make_Component_Name (Item));
- Append_Component_Attr (Result, Defining_Identifier (Item));
end if;
Next (Item);
@@ -690,13 +746,35 @@ package body Exp_Put_Image is
function Make_Component_Name (C : Entity_Id) return Node_Id is
Name : constant Name_Id := Chars (Defining_Identifier (C));
+ pragma Assert (Name /= Name_uParent);
+
+ function To_Upper (S : String) return String;
+ -- Same as Ada.Characters.Handling.To_Upper, but withing
+ -- Ada.Characters.Handling seems to cause mailserver problems.
+
+ --------------
+ -- To_Upper --
+ --------------
+
+ function To_Upper (S : String) return String is
+ begin
+ return Result : String := S do
+ for Char of Result loop
+ Char := Fold_Upper (Char);
+ end loop;
+ end return;
+ end To_Upper;
+
+ -- Start of processing for Make_Component_Name
+
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc),
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S),
- Make_String_Literal (Loc, Get_Name_String (Name) & " => ")));
+ Make_String_Literal (Loc,
+ To_Upper (Get_Name_String (Name)) & " => ")));
end Make_Component_Name;
Stms : constant List_Id := New_List;
@@ -707,38 +785,47 @@ package body Exp_Put_Image is
-- Start of processing for Build_Record_Put_Image_Procedure
begin
- Append_To (Stms,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Record_Before), Loc),
- Parameter_Associations => New_List
- (Make_Identifier (Loc, Name_S))));
+ if Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then
+ Append_To (Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S),
+ Make_String_Literal (Loc, "(NULL RECORD)"))));
+ else
+ Append_To (Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Record_Before), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
- -- Generate Put_Images for the discriminants of the type
+ -- Generate Put_Images for the discriminants of the type
- Append_List_To (Stms,
- Make_Component_Attributes (Discriminant_Specifications (Type_Decl)));
+ Append_List_To (Stms,
+ Make_Component_Attributes
+ (Discriminant_Specifications (Type_Decl)));
- Rdef := Type_Definition (Type_Decl);
+ Rdef := Type_Definition (Type_Decl);
- -- In the record extension case, the components we want, including the
- -- _Parent component representing the parent type, are to be found in
- -- the extension. We will process the _Parent component using the type
- -- of the parent.
+ -- In the record extension case, the components we want are to be
+ -- found in the extension (although we have to process the
+ -- _Parent component to find inherited components).
- if Nkind (Rdef) = N_Derived_Type_Definition then
- Rdef := Record_Extension_Part (Rdef);
- end if;
+ if Nkind (Rdef) = N_Derived_Type_Definition then
+ Rdef := Record_Extension_Part (Rdef);
+ end if;
- if Present (Component_List (Rdef)) then
- Append_List_To (Stms,
- Make_Component_List_Attributes (Component_List (Rdef)));
- end if;
+ if Present (Component_List (Rdef)) then
+ Append_List_To (Stms,
+ Make_Component_List_Attributes (Component_List (Rdef)));
+ end if;
- Append_To (Stms,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Record_After), Loc),
- Parameter_Associations => New_List
- (Make_Identifier (Loc, Name_S))));
+ Append_To (Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Record_After), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
+ end if;
Pnam := Make_Put_Image_Name (Loc, Btyp);
Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms);
@@ -843,9 +930,9 @@ package body Exp_Put_Image is
--
-- Put_Image on tagged types triggers some bugs.
- if Is_Remote_Types (Scope (Typ))
+ if Ada_Version < Ada_2022
+ or else Is_Remote_Types (Scope (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;
@@ -952,7 +1039,7 @@ package body Exp_Put_Image is
-- For T'Image (X) Generate an Expression_With_Actions node:
--
-- do
- -- S : Buffer := New_Buffer;
+ -- S : Buffer;
-- U_Type'Put_Image (S, X);
-- Result : constant String := Get (S);
-- Destroy (S);
@@ -970,13 +1057,16 @@ package body Exp_Put_Image is
Object_Definition =>
New_Occurrence_Of (RTE (RE_Buffer_Type), Loc));
+ Image_Prefix : constant Node_Id :=
+ Duplicate_Subexpr (First (Expressions (N)));
+
Put_Im : constant Node_Id :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (U_Type, Loc),
Attribute_Name => Name_Put_Image,
Expressions => New_List (
New_Occurrence_Of (Sink_Entity, Loc),
- New_Copy_Tree (First (Expressions (N)))));
+ Image_Prefix));
Result_Entity : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('R'));
Result_Decl : constant Node_Id :=
@@ -989,12 +1079,86 @@ package body Exp_Put_Image is
Name => New_Occurrence_Of (RTE (RE_Get), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Sink_Entity, Loc))));
- Image : constant Node_Id :=
- Make_Expression_With_Actions (Loc,
- Actions => New_List (Sink_Decl, Put_Im, Result_Decl),
- Expression => New_Occurrence_Of (Result_Entity, Loc));
+ Actions : List_Id;
+
+ function Put_String_Exp (String_Exp : Node_Id;
+ Wide_Wide : Boolean := False) return Node_Id;
+ -- Generate a call to evaluate a String (or Wide_Wide_String, depending
+ -- on the Wide_Wide Boolean parameter) expression and output it into
+ -- the buffer.
+
+ --------------------
+ -- Put_String_Exp --
+ --------------------
+
+ function Put_String_Exp (String_Exp : Node_Id;
+ Wide_Wide : Boolean := False) return Node_Id is
+ Put_Id : constant RE_Id :=
+ (if Wide_Wide then RE_Wide_Wide_Put else RE_Put_UTF_8);
+
+ -- We could build a nondispatching call here, but to make
+ -- that work we'd have to change Rtsfind spec to make available
+ -- corresponding callees out of Ada.Strings.Text_Buffers.Unbounded
+ -- (as opposed to from Ada.Strings.Text_Buffers). Seems simpler to
+ -- introduce a type conversion and leave it to the optimizer to
+ -- eliminate the dispatching. This does not *introduce* any problems
+ -- if a no-dispatching-allowed restriction is in effect, since we
+ -- are already in the middle of generating a call to T'Class'Image.
+
+ Sink_Exp : constant Node_Id :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc),
+ Expression => New_Occurrence_Of (Sink_Entity, Loc));
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (Put_Id), Loc),
+ Parameter_Associations => New_List (Sink_Exp, String_Exp));
+ end Put_String_Exp;
+
+ -- Start of processing for Build_Image_Call
+
begin
- return Image;
+ if Is_Class_Wide_Type (U_Type) then
+ -- Generate qualified-expression syntax; qualification name comes
+ -- from calling Ada.Tags.Wide_Wide_Expanded_Name.
+
+ declare
+ -- The copy of Image_Prefix will be evaluated before the
+ -- original, which is ok if no side effects are involved.
+
+ pragma Assert (Side_Effect_Free (Image_Prefix));
+
+ Specific_Type_Name : constant Node_Id :=
+ Put_String_Exp
+ (Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Wide_Wide_Expanded_Name), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Image_Prefix),
+ Attribute_Name => Name_Tag))),
+ Wide_Wide => True);
+
+ Qualification : constant Node_Id :=
+ Put_String_Exp (Make_String_Literal (Loc, "'"));
+ begin
+ Actions := New_List
+ (Sink_Decl,
+ Specific_Type_Name,
+ Qualification,
+ Put_Im,
+ Result_Decl);
+ end;
+ else
+ Actions := New_List (Sink_Decl, Put_Im, Result_Decl);
+ end if;
+
+ return Make_Expression_With_Actions (Loc,
+ Actions => Actions,
+ Expression => New_Occurrence_Of (Result_Entity, Loc));
end Build_Image_Call;
------------------------------
@@ -1023,7 +1187,7 @@ 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 Tagged_Put_Image_Enabled
+ and then Ada_Version >= Ada_2022
and then Tagged_Seen
and then not No_Run_Time_Mode
and then RTE_Available (RE_Root_Buffer_Type)
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 21d24cd5eba..fa16887c0d7 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -7591,6 +7591,7 @@ package body Freeze is
or else Is_TSS (Id, TSS_Stream_Output)
or else Is_TSS (Id, TSS_Stream_Read)
or else Is_TSS (Id, TSS_Stream_Write)
+ or else Is_TSS (Id, TSS_Put_Image)
or else Nkind (Original_Node (P)) =
N_Subprogram_Renaming_Declaration)
then
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index ad84e9e761e..6bec611c808 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -708,6 +708,7 @@ package Rtsfind is
RE_TK_Tagged, -- Ada.Tags
RE_TK_Task, -- Ada.Tags
RE_Unregister_Tag, -- Ada.Tags
+ RE_Wide_Wide_Expanded_Name, -- Ada.Tags
RE_Set_Specific_Handler, -- Ada.Task_Termination
RE_Specific_Handler, -- Ada.Task_Termination
@@ -2389,6 +2390,7 @@ package Rtsfind is
RE_TK_Tagged => Ada_Tags,
RE_TK_Task => Ada_Tags,
RE_Unregister_Tag => Ada_Tags,
+ RE_Wide_Wide_Expanded_Name => Ada_Tags,
RE_Set_Specific_Handler => Ada_Task_Termination,
RE_Specific_Handler => Ada_Task_Termination,
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index dcd5954851a..83d7d3c92bc 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -5230,44 +5230,64 @@ package body Sem_Ch13 is
F := First_Formal (Subp);
- if No (F)
- or else Etype (F) /= Class_Wide_Type (RTE (RE_Root_Buffer_Type))
+ if No (F) then
+ return False;
+ end if;
+
+ if Base_Type (Etype (F))
+ /= Class_Wide_Type (RTE (RE_Root_Buffer_Type))
then
+ if Report then
+ Error_Msg_N
+ ("wrong type for Put_Image procedure''s first parameter",
+ Parameter_Type (Parent (F)));
+ end if;
+
return False;
end if;
- Next_Formal (F);
+ if Parameter_Mode (F) /= E_In_Out_Parameter then
+ if Report then
+ Error_Msg_N
+ ("wrong mode for Put_Image procedure''s first parameter",
+ Parent (F));
+ end if;
- if Parameter_Mode (F) /= E_In_Parameter then
return False;
end if;
+ Next_Formal (F);
+
Typ := Etype (F);
-- Verify that the prefix of the attribute and the local name for
-- the type of the formal match.
- if Typ /= Ent then
- return False;
- end if;
+ if Base_Type (Typ) /= Base_Type (Ent) then
+ if Report then
+ Error_Msg_N
+ ("wrong type for Put_Image procedure''s second parameter",
+ Parameter_Type (Parent (F)));
+ end if;
- if Present (Next_Formal (F)) then
return False;
+ end if;
- elsif not Is_Scalar_Type (Typ)
- and then not Is_First_Subtype (Typ)
- then
- if Report and not Is_First_Subtype (Typ) then
+ if Parameter_Mode (F) /= E_In_Parameter then
+ if Report then
Error_Msg_N
- ("subtype of formal in Put_Image operation must be a "
- & "first subtype", Parameter_Type (Parent (F)));
+ ("wrong mode for Put_Image procedure''s second parameter",
+ Parent (F));
end if;
return False;
+ end if;
- else
- return True;
+ if Present (Next_Formal (F)) then
+ return False;
end if;
+
+ return True;
end Has_Good_Profile;
-- Start of processing for Analyze_Put_Image_TSS_Definition
@@ -5386,7 +5406,7 @@ package body Sem_Ch13 is
if No (F)
or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
- or else Designated_Type (Etype (F)) /=
+ or else Base_Type (Designated_Type (Etype (F))) /=
Class_Wide_Type (RTE (RE_Root_Stream_Type))
then
return False;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 7a24298b4c2..42504836bdb 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -19013,56 +19013,6 @@ package body Sem_Ch3 is
return False;
end Is_EVF_Procedure;
- -----------------------
- -- Is_Null_Extension --
- -----------------------
-
- function Is_Null_Extension (T : Entity_Id) return Boolean is
- Type_Decl : constant Node_Id := Parent (Base_Type (T));
- Comp_List : Node_Id;
- Comp : Node_Id;
-
- begin
- if Nkind (Type_Decl) /= N_Full_Type_Declaration
- or else not Is_Tagged_Type (T)
- or else Nkind (Type_Definition (Type_Decl)) /=
- N_Derived_Type_Definition
- or else No (Record_Extension_Part (Type_Definition (Type_Decl)))
- then
- return False;
- end if;
-
- Comp_List :=
- Component_List (Record_Extension_Part (Type_Definition (Type_Decl)));
-
- if Present (Discriminant_Specifications (Type_Decl)) then
- return False;
-
- elsif Present (Comp_List)
- and then Is_Non_Empty_List (Component_Items (Comp_List))
- then
- Comp := First (Component_Items (Comp_List));
-
- -- Only user-defined components are relevant. The component list
- -- may also contain a parent component and internal components
- -- corresponding to secondary tags, but these do not determine
- -- whether this is a null extension.
-
- while Present (Comp) loop
- if Comes_From_Source (Comp) then
- return False;
- end if;
-
- Next (Comp);
- end loop;
-
- return True;
-
- else
- return True;
- end if;
- end Is_Null_Extension;
-
--------------------------
-- Is_Private_Primitive --
--------------------------
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index dcd4a348852..eedb98caf12 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -176,11 +176,6 @@ package Sem_Ch3 is
-- corresponding to that discriminant in the constraint that specifies its
-- value.
- function Is_Null_Extension (T : Entity_Id) return Boolean;
- -- Returns True if the tagged type T has an N_Full_Type_Declaration that
- -- is a null extension, meaning that it has an extension part without any
- -- components and does not have a known discriminant part.
-
function Is_Visible_Component
(C : Entity_Id;
N : Node_Id := Empty) return Boolean;
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 15b700fa983..06c4b07c0c7 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -45,7 +45,6 @@ with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
@@ -1209,7 +1208,7 @@ package body Sem_Disp is
-- primitives.
-- 3. Subprograms associated with stream attributes (built by
- -- New_Stream_Subprogram)
+ -- New_Stream_Subprogram) or with the Put_Image attribute.
-- 4. Wrappers built for inherited operations with inherited class-
-- wide conditions, where the conditions include calls to other
@@ -1238,6 +1237,7 @@ package body Sem_Disp is
or else Get_TSS_Name (Subp) = TSS_Stream_Read
or else Get_TSS_Name (Subp) = TSS_Stream_Write
+ or else Get_TSS_Name (Subp) = TSS_Put_Image
or else
(Is_Wrapper (Subp)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index c0bc4b77f97..e5b76f33cc2 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -712,7 +712,7 @@ package body Sem_Util is
return Make_Level_Literal
(Type_Access_Level (Etype (E)));
- -- A non-discriminant selected component where the component
+ -- A nondiscriminant selected component where the component
-- is an anonymous access type means that its associated
-- level is that of the containing type - see RM 3.10.2 (16).
@@ -18576,18 +18576,143 @@ package body Sem_Util is
return False;
end Is_Nontrivial_DIC_Procedure;
+ -----------------------
+ -- Is_Null_Extension --
+ -----------------------
+
+ function Is_Null_Extension
+ (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean
+ is
+ Type_Decl : Node_Id;
+ Type_Def : Node_Id;
+ begin
+ if Ignore_Privacy then
+ Type_Decl := Parent (Underlying_Type (Base_Type (T)));
+ else
+ Type_Decl := Parent (Base_Type (T));
+ if Nkind (Type_Decl) /= N_Full_Type_Declaration then
+ return False;
+ end if;
+ end if;
+ pragma Assert (Nkind (Type_Decl) = N_Full_Type_Declaration);
+ Type_Def := Type_Definition (Type_Decl);
+ if Present (Discriminant_Specifications (Type_Decl))
+ or else Nkind (Type_Def) /= N_Derived_Type_Definition
+ or else not Is_Tagged_Type (T)
+ or else No (Record_Extension_Part (Type_Def))
+ then
+ return False;
+ end if;
+
+ return Is_Null_Record_Definition (Record_Extension_Part (Type_Def));
+ end Is_Null_Extension;
+
+ --------------------------
+ -- Is_Null_Extension_Of --
+ --------------------------
+
+ function Is_Null_Extension_Of
+ (Descendant, Ancestor : Entity_Id) return Boolean
+ is
+ Ancestor_Type : constant Entity_Id
+ := Underlying_Type (Base_Type (Ancestor));
+ Descendant_Type : Entity_Id := Underlying_Type (Base_Type (Descendant));
+ begin
+ pragma Assert (Descendant_Type /= Ancestor_Type);
+ while Descendant_Type /= Ancestor_Type loop
+ if not Is_Null_Extension
+ (Descendant_Type, Ignore_Privacy => True)
+ then
+ return False;
+ end if;
+ Descendant_Type := Etype (Subtype_Indication
+ (Type_Definition (Parent (Descendant_Type))));
+ Descendant_Type := Underlying_Type (Base_Type (Descendant_Type));
+ end loop;
+ return True;
+ end Is_Null_Extension_Of;
+
+ -------------------------------
+ -- Is_Null_Record_Definition --
+ -------------------------------
+
+ function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean is
+ Item : Node_Id;
+ begin
+ -- Testing Null_Present is just an optimization, not required.
+
+ if Null_Present (Record_Def) then
+ return True;
+ elsif Present (Variant_Part (Component_List (Record_Def))) then
+ return False;
+ elsif not Present (Component_List (Record_Def)) then
+ return True;
+ end if;
+
+ Item := First (Component_Items (Component_List (Record_Def)));
+
+ while Present (Item) loop
+ if Nkind (Item) = N_Component_Declaration
+ and then Is_Internal_Name (Chars (Defining_Identifier (Item)))
+ then
+ null;
+ elsif Nkind (Item) = N_Pragma then
+ null;
+ else
+ return False;
+ end if;
+ Item := Next (Item);
+ end loop;
+
+ return True;
+ end Is_Null_Record_Definition;
+
-------------------------
-- Is_Null_Record_Type --
-------------------------
- function Is_Null_Record_Type (T : Entity_Id) return Boolean is
- Decl : constant Node_Id := Parent (T);
+ function Is_Null_Record_Type
+ (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean
+ is
+ Decl : Node_Id;
+ Type_Def : Node_Id;
begin
- return Nkind (Decl) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (Decl)) = N_Record_Definition
- and then
- (No (Component_List (Type_Definition (Decl)))
- or else Null_Present (Component_List (Type_Definition (Decl))));
+ if not Is_Record_Type (T) then
+ return False;
+ end if;
+
+ if Ignore_Privacy then
+ Decl := Parent (Underlying_Type (Base_Type (T)));
+ else
+ Decl := Parent (Base_Type (T));
+ if Nkind (Decl) /= N_Full_Type_Declaration then
+ return False;
+ end if;
+ end if;
+ pragma Assert (Nkind (Decl) = N_Full_Type_Declaration);
+ Type_Def := Type_Definition (Decl);
+
+ if Has_Discriminants (Defining_Identifier (Decl)) then
+ return False;
+ end if;
+
+ case Nkind (Type_Def) is
+ when N_Record_Definition =>
+ return Is_Null_Record_Definition (Type_Def);
+ when N_Derived_Type_Definition =>
+ if not Is_Null_Record_Type
+ (Etype (Subtype_Indication (Type_Def)),
+ Ignore_Privacy => Ignore_Privacy)
+ then
+ return False;
+ elsif not Is_Tagged_Type (T) then
+ return True;
+ else
+ return Is_Null_Extension (T, Ignore_Privacy => Ignore_Privacy);
+ end if;
+ when others =>
+ return False;
+ end case;
end Is_Null_Record_Type;
---------------------
@@ -19183,7 +19308,7 @@ package body Sem_Util is
elsif Is_Tagged_Type (Typ) then
return True;
- -- Case of non-discriminated record
+ -- Case of nondiscriminated record
else
declare
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 10f1ba52795..0894d034085 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2126,9 +2126,28 @@ package Sem_Util is
-- assertion expression of pragma Default_Initial_Condition and if it does,
-- the encapsulated expression is nontrivial.
- function Is_Null_Record_Type (T : Entity_Id) return Boolean;
- -- Determine whether T is declared with a null record definition or a
- -- null component list.
+ function Is_Null_Extension
+ (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean;
+ -- Given a tagged type, returns True if argument is a type extension
+ -- that introduces no new components (discriminant or nondiscriminant).
+ -- Ignore_Privacy should be True for use in implementing dynamic semantics.
+
+ function Is_Null_Extension_Of
+ (Descendant, Ancestor : Entity_Id) return Boolean;
+ -- Given two tagged types, the first a descendant of the second,
+ -- returns True if every component of Descendant is inherited
+ -- (directly or indirectly) from Ancestor. Privacy is ignored.
+
+ function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean;
+ -- Returns True for an N_Record_Definition node that has no user-defined
+ -- components (and no variant part).
+
+ function Is_Null_Record_Type
+ (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean;
+ -- Determine whether T is declared with a null record definition, a
+ -- null component list, or as a type derived from a null record type
+ -- (with a null extension if tagged). Returns True for interface types,
+ -- False for discriminated types.
function Is_Object_Image (Prefix : Node_Id) return Boolean;
-- Returns True if an 'Img, 'Image, 'Wide_Image, or 'Wide_Wide_Image
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-07-05 13:13 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-07-05 13:13 [gcc r12-2011] [Ada] Add Ada 2022 Image and Put_Image support for tagged types Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).