From: Justin Squirek <squi...@adacore.com>
This patch further enhances the mutably tagged type implementation by fixing
several oversights relating to generic instantiations, attributes, and
type conversions.
gcc/ada/
* exp_put_image.adb (Append_Component_Attr): Obtain the mutably
tagged type for the component type.
* mutably_tagged.adb (Make_Mutably_Tagged_Conversion): Add more
cases to avoid conversion generation.
* sem_attr.adb (Check_Put_Image_Attribute): Add mutably tagged
type conversion.
* sem_ch12.adb (Analyze_One_Association): Add rewrite for formal
type declarations which are mutably tagged type to their
equivalent type.
(Instantiate_Type): Add condition to obtain class wide equivalent
types.
(Validate_Private_Type_Instance): Add check for class wide
equivalent types which are considered "definite".
* sem_util.adb (Is_Variable): Add condition to handle selected
components of view conversions. Add missing check for selected
components.
(Is_View_Conversion): Add condition to handle class wide
equivalent types.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_put_image.adb | 25 ++++++++++++++-----------
gcc/ada/mutably_tagged.adb | 21 ++++++++++++++-------
gcc/ada/sem_attr.adb | 7 +++++++
gcc/ada/sem_ch12.adb | 25 +++++++++++++++++++++++--
gcc/ada/sem_util.adb | 14 +++++++++++++-
5 files changed, 71 insertions(+), 21 deletions(-)
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index bf14eded93e..217c38a30e7 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -32,6 +32,7 @@ with Einfo.Utils; use Einfo.Utils;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -402,9 +403,9 @@ package body Exp_Put_Image is
end;
end Build_Elementary_Put_Image_Call;
- -------------------------------------
+ ---------------------------------
-- Build_String_Put_Image_Call --
- -------------------------------------
+ ---------------------------------
function Build_String_Put_Image_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
@@ -485,9 +486,9 @@ package body Exp_Put_Image is
Relocate_Node (Sink)));
end Build_Protected_Put_Image_Call;
- ------------------------------------
+ -------------------------------
-- Build_Task_Put_Image_Call --
- ------------------------------------
+ -------------------------------
-- For "Task_Type'Put_Image (S, Task_Object)", build:
--
@@ -650,12 +651,14 @@ package body Exp_Put_Image is
return Result;
end Make_Component_List_Attributes;
- --------------------------------
+ ---------------------------
-- Append_Component_Attr --
- --------------------------------
+ ---------------------------
procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is
- Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C));
+ Component_Typ : constant Entity_Id :=
+ Put_Image_Base_Type
+ (Get_Corresponding_Mutably_Tagged_Type_If_Present (Etype (C)));
begin
if Ekind (C) /= E_Void then
Append_To (Clist,
@@ -936,9 +939,9 @@ package body Exp_Put_Image is
Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms);
end Build_Record_Put_Image_Procedure;
- -------------------------------
+ -----------------------------
-- Build_Put_Image_Profile --
- -------------------------------
+ -----------------------------
function Build_Put_Image_Profile
(Loc : Source_Ptr; Typ : Entity_Id) return List_Id
@@ -983,9 +986,9 @@ package body Exp_Put_Image is
Statements => Stms));
end Build_Put_Image_Proc;
- ------------------------------------
+ ----------------------------------
-- Build_Unknown_Put_Image_Call --
- ------------------------------------
+ ----------------------------------
function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
diff --git a/gcc/ada/mutably_tagged.adb b/gcc/ada/mutably_tagged.adb
index 34b032f08c8..495cdd0fcfb 100644
--- a/gcc/ada/mutably_tagged.adb
+++ b/gcc/ada/mutably_tagged.adb
@@ -272,15 +272,22 @@ package body Mutably_Tagged is
if Force
-- Otherwise, don't make the conversion when N is on the left-hand
- -- side of the assignment, is already part of an unchecked conversion,
- -- or is part of a renaming.
+ -- side of the assignment, in cases where we need the actual type
+ -- such as a subtype or object renaming declaration, or a generic or
+ -- parameter specification.
+
+ -- Additionally, prevent generation of the conversion if N is already
+ -- part of an unchecked conversion or a part of a selected component.
or else (not Known_To_Be_Assigned (N, Only_LHS => True)
- and then (No (Parent (N))
- or else Nkind (Parent (N))
- not in N_Selected_Component
- | N_Unchecked_Type_Conversion
- | N_Object_Renaming_Declaration))
+ and then (No (Parent (N))
+ or else Nkind (Parent (N))
+ not in N_Selected_Component
+ | N_Subtype_Declaration
+ | N_Parameter_Specification
+ | N_Generic_Association
+ | N_Unchecked_Type_Conversion
+ | N_Object_Renaming_Declaration))
then
-- Exclude the case where we have a 'Size so that we get the proper
-- size of the class-wide equivalent type. Are there other cases ???
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index a5c90e3f36d..994a45becdc 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -2682,6 +2682,13 @@ package body Sem_Attr is
E1);
end if;
+ -- Generate a conversion from a class-wide equivalent type (if
+ -- present) to the relevant actual type E2.
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (E2)) then
+ Make_Mutably_Tagged_Conversion (E2);
+ end if;
+
-- Check that the second argument is of the right type
Analyze (E2);
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 0f8792c3a82..bc0d34e871d 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -2419,9 +2419,9 @@ package body Sem_Ch12 is
-- but there is "others => <>". Add a copy of the declaration of the
-- generic formal to the Result_Renamings.
- ---------------------
+ ------------------------
-- Process_Box_Actual --
- ---------------------
+ ------------------------
procedure Process_Box_Actual (Formal : Node_Id) is
pragma Assert (Assoc.Actual.Kind = Box_Actual);
@@ -2535,6 +2535,19 @@ package body Sem_Ch12 is
else
Analyze (Match);
+
+ -- Rewrite mutably tagged types to be their class-wide
+ -- equivalent type.
+
+ if Ekind (Etype (Match)) /= E_Void
+ and then Is_Mutably_Tagged_Type (Etype (Match))
+ then
+ Rewrite (Match, New_Occurrence_Of
+ (Class_Wide_Equivalent_Type
+ (Etype (Match)), Sloc (Match)));
+ Analyze (Match);
+ end if;
+
Append_List
(Instantiate_Type
(Assoc.Un_Formal, Match, Assoc.An_Formal,
@@ -14928,6 +14941,7 @@ package body Sem_Ch12 is
elsif not Is_Definite_Subtype (Act_T)
and then Is_Definite_Subtype (A_Gen_T)
+ and then No (Class_Wide_Equivalent_Type (Act_T))
and then Ada_Version >= Ada_95
then
Error_Msg_NE
@@ -14957,6 +14971,13 @@ package body Sem_Ch12 is
Act_T := Entity (Actual);
+ -- Obtain the class-wide equivalent type and use it for the
+ -- instantiation instead of a mutably tagged type.
+
+ if Present (Class_Wide_Equivalent_Type (Act_T)) then
+ Act_T := Class_Wide_Equivalent_Type (Act_T);
+ end if;
+
-- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
-- as a generic actual parameter if the corresponding formal type
-- does not have a known_discriminant_part, or is a formal derived
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 7b575c09c30..3f956098c6d 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -21052,6 +21052,16 @@ package body Sem_Util is
if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
return True;
+ -- It is possible that N is a selected component of a view conversion,
+ -- and in that case get the expression of the conversion and test
+ -- whether it is indeed a variable.
+
+ elsif Nkind (N) = N_Selected_Component
+ and then Is_View_Conversion (Ultimate_Prefix (N))
+ and then Is_Variable (Expression (Ultimate_Prefix (N)))
+ then
+ return True;
+
-- Normally we go to the original node, but there is one exception where
-- we use the rewritten node, namely when it is an explicit dereference.
-- The generated code may rewrite a prefix which is an access type with
@@ -21205,7 +21215,9 @@ package body Sem_Util is
and then Nkind (Unqual_Conv (N)) in N_Has_Etype
then
if Is_Tagged_Type (Etype (N))
- and then Is_Tagged_Type (Etype (Unqual_Conv (N)))
+ and then (Is_Tagged_Type (Etype (Unqual_Conv (N)))
+ or else Is_Class_Wide_Equivalent_Type
+ (Etype (Unqual_Conv (N))))
then
return True;
--
2.45.2
