From: Steve Baird <ba...@adacore.com>
Fix bugs related to mutably tagged types in streaming operations, Put_Image
attributes, aggregates, composite equality comparisons with mutably-tagged
components, and other issues.
gcc/ada/ChangeLog:
* exp_aggr.adb (Build_Record_Aggr_Code.Gen_Assign): In the case of
an aggregate component where the component type is mutably tagged
and the component value is provided by a qualified aggregate (and
qualified with a specific type), avoid incorrectly rejecting the
inner aggregate for violating the rule that the type of an
aggregate shall not be class-wide.
* exp_attr.adb: For a predefined streaming operation (i.e., Read,
Write, Input, or Output) of a class-wide type, the external name
of the tag of the value is normally written out by Output and read
in by Input. In the case of a mutably tagged type, this is instead
done in Write and Read.
* exp_ch4.adb (Expand_Composite_Equality): In the case of an
equality comparison for a type having a mutably tagged component,
we want the component comparison to compare two values of the
mutably tagged type, not two values of the corresponding
array-of-bytes-ish representation type. Even if there are no
user-defined equality functions anywhere in sight, comparing the
array values still doesn't work because undefined bits may end up
participating in the comparison (resulting in an incorrect result
of False).
* exp_put_image.adb: In the case of a class-wide type, the
predefined Image attribute includes the name of the specific type
(and a "'" character, to follow qualified expression syntax) to
indicate the tag of the value. With the introduction of mutably
tagged types, this case can now arise in the case of a component
(of either an enclosing array or an enclosing record), not just
for a top-level object. So we factor the code to do this into a
new procedure, Put_Specific_Type_Name_Qualifier, so that it can be
called from more than one place. This reorganization also involves
replacing the procedure Put_String_Exp with a new procedure,
Put_String_Exp_To_Buffer, declared in a less nested scope. For
mutably tagged components (at the source level) the component type
(at the GNAT tree level) is an array of bytes (actually a two
field record containing an array of bytes, but that's a detail).
Appropriate conversions need to be generated so that we don't end
up generating an image for an array of bytes; this is done at the
same places where Put_Specific_Type_Name_Qualifier is called
(for components) by calling Make_Mutably_Tagged_Conversion.
* exp_strm.adb (Make_Field_Attribute): Add
Make_Mutably_Tagged_Conversion call where we construct a
Selected_Component node and the corresponding component type is
the internal representation type for a mutably tagged type.
(Stream_Base_Type): Return the mutably
tagged type if given the corresponding internal representation type.
* sem_ch3.adb (Array_Type_Declaration): In the case where the
source-level component type of an array type is mutably tagged,
set the Component_Type field of the base type of the declared
array type (as opposed to that of the first subtype of the array
type) to the corresponding internal representation type.
* sem_ch4.adb (Analyze_Selected_Component): In the case of a
selected component name which references a component whose type is
the internal representation type of a mutably tagged type,
generate a conversion to the mutably tagged type.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 5 +-
gcc/ada/exp_attr.adb | 404 ++++++++++++++++++++++++--------------
gcc/ada/exp_ch4.adb | 10 +-
gcc/ada/exp_put_image.adb | 343 ++++++++++++++++++--------------
gcc/ada/exp_strm.adb | 35 ++--
gcc/ada/sem_ch3.adb | 2 +-
gcc/ada/sem_ch4.adb | 4 +
7 files changed, 498 insertions(+), 305 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index bdb4c8556f2..2f3bab44a78 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1422,8 +1422,11 @@ package body Exp_Aggr is
elsif Is_Mutably_Tagged_Type (Comp_Typ)
and then Nkind (Expr) = N_Qualified_Expression
then
- Analyze_And_Resolve (Expr_Q, Etype (Expr));
+ -- Avoid class-wide expected type for aggregate
+ -- (which would be rejected as illegal)
+ -- if the aggregate is explicitly qualified.
+ Analyze_And_Resolve (Expr_Q, Etype (Expr));
else
Analyze_And_Resolve (Expr_Q, Comp_Typ);
end if;
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 4f9f16cfa55..810248de1ac 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -1915,6 +1915,15 @@ package body Exp_Attr is
-- call to the appropriate TSS procedure. Pname is the entity for the
-- procedure to call.
+ procedure Read_Controlling_Tag
+ (P_Type : Entity_Id; Cntrl : out Node_Id);
+ -- Read the external tag from the stream and use it to construct the
+ -- controlling operand for a dispatching call.
+
+ procedure Write_Controlling_Tag (P_Type : Entity_Id);
+ -- Write the external tag of the given attribute prefix type to
+ -- the stream. Also perform the accompanying accessibility check.
+
-------------------------------------
-- Build_And_Insert_Type_Attr_Subp --
-------------------------------------
@@ -2175,6 +2184,153 @@ package body Exp_Attr is
Analyze (N);
end Rewrite_Attribute_Proc_Call;
+ --------------------------
+ -- Read_Controlling_Tag --
+ --------------------------
+
+ procedure Read_Controlling_Tag
+ (P_Type : Entity_Id; Cntrl : out Node_Id)
+ is
+ Strm : constant Node_Id := First (Exprs);
+ Expr : Node_Id; -- call to Descendant_Tag
+ Get_Tag : Node_Id; -- expression to read the 'Tag
+
+ begin
+ -- Read the internal tag (RM 13.13.2(34)) and use it to
+ -- initialize a dummy tag value. We used to unconditionally
+ -- generate:
+ --
+ -- Descendant_Tag (String'Input (Strm), P_Type);
+ --
+ -- which turns into a call to String_Input_Blk_IO. However,
+ -- if the input is malformed, that could try to read an
+ -- enormous String, causing chaos. So instead we call
+ -- String_Input_Tag, which does the same thing as
+ -- String_Input_Blk_IO, except that if the String is
+ -- absurdly long, it raises an exception.
+ --
+ -- However, if the No_Stream_Optimizations restriction
+ -- is active, we disable this unnecessary attempt at
+ -- robustness; we really need to read the string
+ -- character-by-character.
+ --
+ -- This value is used only to provide a controlling
+ -- argument for the eventual _Input call. Descendant_Tag is
+ -- called rather than Internal_Tag to ensure that we have a
+ -- tag for a type that is descended from the prefix type and
+ -- declared at the same accessibility level (the exception
+ -- Tag_Error will be raised otherwise). The level check is
+ -- required for Ada 2005 because tagged types can be
+ -- extended in nested scopes (AI-344).
+
+ -- Note: we used to generate an explicit declaration of a
+ -- constant Ada.Tags.Tag object, and use an occurrence of
+ -- this constant in Cntrl, but this caused a secondary stack
+ -- leak.
+
+ if Restriction_Active (No_Stream_Optimizations) then
+ Get_Tag :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_String, Loc),
+ Attribute_Name => Name_Input,
+ Expressions => New_List (
+ Relocate_Node (Duplicate_Subexpr (Strm))));
+ else
+ Get_Tag :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_String_Input_Tag), Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Duplicate_Subexpr (Strm))));
+ end if;
+
+ Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
+ Parameter_Associations => New_List (
+ Get_Tag,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (P_Type, Loc),
+ Attribute_Name => Name_Tag)));
+
+ Set_Etype (Expr, RTE (RE_Tag));
+
+ -- Construct a controlling operand for a dispatching call.
+
+ Cntrl := Unchecked_Convert_To (P_Type, Expr);
+ Set_Etype (Cntrl, P_Type);
+ Set_Parent (Cntrl, N);
+ end Read_Controlling_Tag;
+
+ ----------------------------
+ -- Write_Controlling_Tag --
+ ----------------------------
+
+ procedure Write_Controlling_Tag (P_Type : Entity_Id) is
+ Strm : constant Node_Id := First (Exprs);
+ Item : constant Node_Id := Next (Strm);
+ begin
+ -- Ada 2005 (AI-344): Check that the accessibility level
+ -- of the type of the output object is not deeper than
+ -- that of the attribute's prefix type.
+
+ -- if Get_Access_Level (Item'Tag)
+ -- /= Get_Access_Level (P_Type'Tag)
+ -- then
+ -- raise Tag_Error;
+ -- end if;
+
+ -- String'Output (Strm, External_Tag (Item'Tag));
+
+ -- We cannot figure out a practical way to implement this
+ -- accessibility check on virtual machines, so we omit it.
+
+ if Ada_Version >= Ada_2005
+ and then Tagged_Type_Expansion
+ then
+ Insert_Action (N,
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Build_Get_Access_Level (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Relocate_Node (
+ Duplicate_Subexpr (Item,
+ Name_Req => True)),
+ Attribute_Name => Name_Tag)),
+
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Type_Access_Level (P_Type))),
+
+ Then_Statements =>
+ New_List (Make_Raise_Statement (Loc,
+ New_Occurrence_Of (
+ RTE (RE_Tag_Error), Loc)))));
+ end if;
+
+ Insert_Action (N,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Standard_String, Loc),
+ Attribute_Name => Name_Output,
+ Expressions => New_List (
+ Relocate_Node (Duplicate_Subexpr (Strm)),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_External_Tag), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Relocate_Node
+ (Duplicate_Subexpr (Item, Name_Req => True)),
+ Attribute_Name => Name_Tag))))));
+ end Write_Controlling_Tag;
+
Typ : constant Entity_Id := Etype (N);
Btyp : constant Entity_Id := Base_Type (Typ);
Ptyp : constant Entity_Id := Etype (Pref);
@@ -4487,6 +4643,47 @@ package body Exp_Attr is
elsif Is_Class_Wide_Type (P_Type) then
+ if Is_Mutably_Tagged_Type (P_Type) then
+
+ -- In mutably tagged case, rewrite
+ -- T'Class'Input (Strm)
+ -- as (roughly)
+ -- declare
+ -- Result : T'Class;
+ -- T'Class'Read (Strm, Result);
+ -- begin
+ -- Result;
+ -- end;
+
+ declare
+ Result_Temp : constant Entity_Id :=
+ Make_Temporary (Loc, 'I');
+
+ -- Gets default initialization
+ Result_Temp_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Result_Temp,
+ Object_Definition =>
+ New_Occurrence_Of (P_Type, Loc));
+
+ function Result_Temp_Name return Node_Id is
+ (New_Occurrence_Of (Result_Temp, Loc));
+
+ Actions : constant List_Id := New_List (
+ Result_Temp_Decl,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (P_Type, Loc),
+ Attribute_Name => Name_Read,
+ Expressions => New_List (
+ Relocate_Node (Strm), Result_Temp_Name)));
+ begin
+ Rewrite (N, Make_Expression_With_Actions (Loc,
+ Actions, Result_Temp_Name));
+ Analyze_And_Resolve (N, P_Type);
+ return;
+ end;
+ end if;
+
-- No need to do anything else compiling under restriction
-- No_Dispatching_Calls. During the semantic analysis we
-- already notified such violation.
@@ -4495,86 +4692,8 @@ package body Exp_Attr is
return;
end if;
- declare
- Rtyp : constant Entity_Id := Root_Type (P_Type);
-
- Expr : Node_Id; -- call to Descendant_Tag
- Get_Tag : Node_Id; -- expression to read the 'Tag
-
- begin
- -- Read the internal tag (RM 13.13.2(34)) and use it to
- -- initialize a dummy tag value. We used to unconditionally
- -- generate:
- --
- -- Descendant_Tag (String'Input (Strm), P_Type);
- --
- -- which turns into a call to String_Input_Blk_IO. However,
- -- if the input is malformed, that could try to read an
- -- enormous String, causing chaos. So instead we call
- -- String_Input_Tag, which does the same thing as
- -- String_Input_Blk_IO, except that if the String is
- -- absurdly long, it raises an exception.
- --
- -- However, if the No_Stream_Optimizations restriction
- -- is active, we disable this unnecessary attempt at
- -- robustness; we really need to read the string
- -- character-by-character.
- --
- -- This value is used only to provide a controlling
- -- argument for the eventual _Input call. Descendant_Tag is
- -- called rather than Internal_Tag to ensure that we have a
- -- tag for a type that is descended from the prefix type and
- -- declared at the same accessibility level (the exception
- -- Tag_Error will be raised otherwise). The level check is
- -- required for Ada 2005 because tagged types can be
- -- extended in nested scopes (AI-344).
-
- -- Note: we used to generate an explicit declaration of a
- -- constant Ada.Tags.Tag object, and use an occurrence of
- -- this constant in Cntrl, but this caused a secondary stack
- -- leak.
-
- if Restriction_Active (No_Stream_Optimizations) then
- Get_Tag :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Standard_String, Loc),
- Attribute_Name => Name_Input,
- Expressions => New_List (
- Relocate_Node (Duplicate_Subexpr (Strm))));
- else
- Get_Tag :=
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_String_Input_Tag), Loc),
- Parameter_Associations => New_List (
- Relocate_Node (Duplicate_Subexpr (Strm))));
- end if;
-
- Expr :=
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
- Parameter_Associations => New_List (
- Get_Tag,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (P_Type, Loc),
- Attribute_Name => Name_Tag)));
-
- Set_Etype (Expr, RTE (RE_Tag));
-
- -- Now we need to get the entity for the call, and construct
- -- a function call node, where we preset a reference to Dnn
- -- as the controlling argument (doing an unchecked convert
- -- to the class-wide tagged type to make it look like a real
- -- tagged object).
-
- Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
- Cntrl := Unchecked_Convert_To (P_Type, Expr);
- Set_Etype (Cntrl, P_Type);
- Set_Parent (Cntrl, N);
- end;
+ Read_Controlling_Tag (P_Type, Cntrl);
+ Fname := Find_Prim_Op (Root_Type (P_Type), TSS_Stream_Input);
-- For tagged types, use the primitive Input function
@@ -5957,6 +6076,14 @@ package body Exp_Attr is
Attr_Ref => N);
end;
+ -- In the mutably tagged case, T'Class'Output calls T'Class'Write;
+ -- T'Write will take care of writing out the external tag.
+
+ elsif Is_Mutably_Tagged_Type (P_Type) then
+ Set_Attribute_Name (N, Name_Write);
+ Analyze (N);
+ return;
+
-- Class-wide case, first output external tag, then dispatch
-- to the appropriate primitive Output function (RM 13.13.2(31)).
@@ -5970,68 +6097,7 @@ package body Exp_Attr is
return;
end if;
- Tag_Write : declare
- Strm : constant Node_Id := First (Exprs);
- Item : constant Node_Id := Next (Strm);
-
- begin
- -- Ada 2005 (AI-344): Check that the accessibility level
- -- of the type of the output object is not deeper than
- -- that of the attribute's prefix type.
-
- -- if Get_Access_Level (Item'Tag)
- -- /= Get_Access_Level (P_Type'Tag)
- -- then
- -- raise Tag_Error;
- -- end if;
-
- -- String'Output (Strm, External_Tag (Item'Tag));
-
- -- We cannot figure out a practical way to implement this
- -- accessibility check on virtual machines, so we omit it.
-
- if Ada_Version >= Ada_2005
- and then Tagged_Type_Expansion
- then
- Insert_Action (N,
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Build_Get_Access_Level (Loc,
- Make_Attribute_Reference (Loc,
- Prefix =>
- Relocate_Node (
- Duplicate_Subexpr (Item,
- Name_Req => True)),
- Attribute_Name => Name_Tag)),
-
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Type_Access_Level (P_Type))),
-
- Then_Statements =>
- New_List (Make_Raise_Statement (Loc,
- New_Occurrence_Of (
- RTE (RE_Tag_Error), Loc)))));
- end if;
-
- Insert_Action (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_String, Loc),
- Attribute_Name => Name_Output,
- Expressions => New_List (
- Relocate_Node (Duplicate_Subexpr (Strm)),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_External_Tag), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- Relocate_Node
- (Duplicate_Subexpr (Item, Name_Req => True)),
- Attribute_Name => Name_Tag))))));
- end Tag_Write;
+ Write_Controlling_Tag (P_Type);
Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
@@ -6793,6 +6859,7 @@ package body Exp_Attr is
P_Type : constant Entity_Id := Entity (Pref);
B_Type : constant Entity_Id := Base_Type (P_Type);
U_Type : constant Entity_Id := Underlying_Type (P_Type);
+ Cntrl : Node_Id := Empty; -- nonempty only if P_Type mutably tagged
Pname : Entity_Id;
Decl : Node_Id;
Prag : Node_Id;
@@ -6941,6 +7008,11 @@ package body Exp_Attr is
-- this will dispatch in the class-wide case which is what we want
elsif Is_Tagged_Type (U_Type) then
+
+ if Is_Mutably_Tagged_Type (U_Type) then
+ Read_Controlling_Tag (P_Type, Cntrl);
+ end if;
+
Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
-- All other record type cases, including protected records. The
@@ -7001,6 +7073,46 @@ package body Exp_Attr is
Rewrite_Attribute_Proc_Call (Pname);
+ if Present (Cntrl) then
+ pragma Assert (Is_Mutably_Tagged_Type (U_Type));
+ pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
+
+ -- Assign the Tag value that was read from the stream
+ -- to the tag of the out-mode actual parameter so that
+ -- we dispatch correctly. This isn't quite right.
+ -- We should assign a complete object (not just
+ -- the tag), but that would require a dispatching call to
+ -- perform default initialization of the source object and
+ -- dispatching default init calls are currently not supported.
+
+ declare
+ function Select_Tag (Prefix : Node_Id) return Node_Id is
+ (Make_Selected_Component (Loc,
+ Prefix => Prefix,
+ Selector_Name =>
+ New_Occurrence_Of (First_Tag_Component
+ (Etype (Prefix)), Loc)));
+
+ Controlling_Actual : constant Node_Id :=
+ Next (First (Parameter_Associations (N)));
+
+ pragma Assert (Is_Controlling_Actual (Controlling_Actual));
+
+ Assign_Tag : Node_Id;
+ begin
+ Remove_Side_Effects (Controlling_Actual, Name_Req => True);
+
+ Assign_Tag :=
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Select_Tag (New_Copy_Tree (Controlling_Actual)),
+ Expression => Select_Tag (Cntrl));
+
+ Insert_Before (Before => N, Node => Assign_Tag);
+ Analyze (Assign_Tag);
+ end;
+ end if;
+
if not Is_Tagged_Type (P_Type) then
Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname);
end if;
@@ -8611,6 +8723,14 @@ package body Exp_Attr is
-- this will dispatch in the class-wide case which is what we want
elsif Is_Tagged_Type (U_Type) then
+
+ -- If T'Class is mutably tagged, then the external tag
+ -- is written out by T'Class'Write, not by T'Class'Output.
+
+ if Is_Mutably_Tagged_Type (U_Type) then
+ Write_Controlling_Tag (P_Type);
+ end if;
+
Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
-- All other record type cases, including protected records.
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 76386fc9f6a..43c94f37ba1 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -2354,6 +2354,7 @@ package body Exp_Ch4 is
Rhs : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
+ CW_Comp : Boolean := False;
Full_Type : Entity_Id;
Eq_Op : Entity_Id;
@@ -2383,10 +2384,17 @@ package body Exp_Ch4 is
Full_Type := Underlying_Type (Full_Type);
end if;
+ if Is_Class_Wide_Equivalent_Type (Full_Type) then
+ CW_Comp := True;
+ Full_Type :=
+ Get_Corresponding_Mutably_Tagged_Type_If_Present (Full_Type);
+ pragma Assert (Is_Tagged_Type (Full_Type));
+ end if;
+
-- Case of tagged record types
if Is_Tagged_Type (Full_Type) then
- Eq_Op := Find_Primitive_Eq (Comp_Type);
+ Eq_Op := Find_Primitive_Eq (if CW_Comp then Full_Type else Comp_Type);
pragma Assert (Present (Eq_Op));
return
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 40b2a65b821..ce3390b5038 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -77,8 +77,28 @@ package body Exp_Put_Image is
-- reference). The Loc parameter is used as the Sloc of the created entity.
function Put_Image_Base_Type (E : Entity_Id) return Entity_Id;
- -- Returns the base type, except for an array type whose whose first
- -- subtype is constrained, in which case it returns the first subtype.
+ -- For an array type whose whose first subtype is constrained, return
+ -- the first subtype. For the internal representation type corresponding
+ -- to a mutably tagged type, return the mutably tagged type. Otherwise,
+ -- return the base type. Similar to Exp_Strm.Stream_Base_Type.
+
+ procedure Put_Specific_Type_Name_Qualifier
+ (Loc : Source_Ptr;
+ Stms : List_Id;
+ Tagged_Obj : Node_Id;
+ Buffer_Name : Node_Id;
+ Is_Interface_Type : Boolean);
+ -- Append to the given statement list calls to add into the
+ -- buffer the name of the given object's tag and then a "'".
+
+ function Put_String_Exp_To_Buffer
+ (Loc : Source_Ptr;
+ String_Exp : Node_Id;
+ Buffer_Name : 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.
-------------------------------------
-- Build_Array_Put_Image_Procedure --
@@ -189,7 +209,7 @@ package body Exp_Put_Image is
Ndim : constant Pos := Number_Dimensions (Typ);
Ctyp : constant Entity_Id := Component_Type (Typ);
- Stm : Node_Id;
+ Stms : List_Id := New_List;
Exl : constant List_Id := New_List;
PI_Entity : Entity_Id;
@@ -220,15 +240,36 @@ package body Exp_Put_Image is
Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', Dim)));
end loop;
- Stm :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Put_Image_Base_Type (Ctyp), Loc),
- Attribute_Name => Name_Put_Image,
- Expressions => New_List (
- Make_Identifier (Loc, Name_S),
- Make_Indexed_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Expressions => Exl)));
+ declare
+ Ctype_For_Call : constant Entity_Id := Put_Image_Base_Type (Ctyp);
+ Indexed_Comp : constant Node_Id :=
+ Make_Indexed_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Expressions => Exl);
+ begin
+ if Is_Mutably_Tagged_Type (Ctype_For_Call) then
+ pragma Assert (not Is_Mutably_Tagged_Type (Component_Type (Typ)));
+
+ Make_Mutably_Tagged_Conversion (Indexed_Comp,
+ Typ => Ctype_For_Call);
+
+ pragma Assert (Is_Mutably_Tagged_Type (Etype (Indexed_Comp)));
+
+ Put_Specific_Type_Name_Qualifier (Loc,
+ Stms => Stms,
+ Tagged_Obj => Indexed_Comp,
+ Buffer_Name => Make_Identifier (Loc, Name_S),
+ Is_Interface_Type => False);
+ end if;
+
+ Append_To (Stms,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ctype_For_Call, Loc),
+ Attribute_Name => Name_Put_Image,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ Indexed_Comp)));
+ end;
-- The corresponding attribute for the component type of the array might
-- be user-defined, and frozen after the array type. In that case,
@@ -245,46 +286,42 @@ package body Exp_Put_Image is
-- Loop through the dimensions, innermost first, generating a loop for
-- each dimension.
- declare
- Stms : List_Id := New_List (Stm);
- begin
- for Dim in reverse 1 .. Ndim loop
- declare
- New_Stms : constant List_Id := New_List;
- Between_Proc : RE_Id;
- begin
- -- For a one-dimensional array of elementary type, use
- -- RE_Simple_Array_Between. The same applies to the last
- -- dimension of a multidimensional array.
+ for Dim in reverse 1 .. Ndim loop
+ declare
+ New_Stms : constant List_Id := New_List;
+ Between_Proc : RE_Id;
+ begin
+ -- For a one-dimensional array of elementary type, use
+ -- RE_Simple_Array_Between. The same applies to the last
+ -- dimension of a multidimensional array.
- if Is_Elementary_Type (Ctyp) and then Dim = Ndim then
- Between_Proc := RE_Simple_Array_Between;
- else
- Between_Proc := RE_Array_Between;
- end if;
+ if Is_Elementary_Type (Ctyp) and then Dim = Ndim then
+ Between_Proc := RE_Simple_Array_Between;
+ else
+ Between_Proc := RE_Array_Between;
+ end if;
- Append_To (New_Stms,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Array_Before), Loc),
- Parameter_Associations => New_List
- (Make_Identifier (Loc, Name_S))));
+ Append_To (New_Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Array_Before), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
- Append_To
- (New_Stms,
- Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc));
+ Append_To
+ (New_Stms,
+ Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc));
- Append_To (New_Stms,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Array_After), Loc),
- Parameter_Associations => New_List
- (Make_Identifier (Loc, Name_S))));
+ Append_To (New_Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Array_After), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S))));
- Stms := New_Stms;
- end;
- end loop;
+ Stms := New_Stms;
+ end;
+ end loop;
- Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms);
- end;
+ Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms);
end Build_Array_Put_Image_Procedure;
-------------------------------------
@@ -379,7 +416,8 @@ package body Exp_Put_Image is
begin
-- We have built a dispatching call to handle calls to
-- descendants (since they are not available through rtsfind).
- -- Further details available in the body of Put_String_Exp.
+ -- Further details available in the body of
+ -- Put_String_Exp_To_Buffer.
return Put_Call;
end;
@@ -691,19 +729,33 @@ package body Exp_Put_Image is
---------------------------
procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is
- Component_Typ : constant Entity_Id :=
- Put_Image_Base_Type
- (Get_Corresponding_Mutably_Tagged_Type_If_Present (Etype (C)));
+ Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C));
+ Selected_Comp : constant Node_Id :=
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name => New_Occurrence_Of (C, Loc));
begin
+ if Is_Mutably_Tagged_Type (Component_Typ) then
+ pragma Assert (not Is_Mutably_Tagged_Type (Etype (C)));
+
+ Make_Mutably_Tagged_Conversion (Selected_Comp,
+ Typ => Component_Typ);
+
+ pragma Assert (Is_Mutably_Tagged_Type (Etype (Selected_Comp)));
+
+ Put_Specific_Type_Name_Qualifier (Loc,
+ Stms => Clist,
+ Tagged_Obj => Selected_Comp,
+ Buffer_Name => Make_Identifier (Loc, Name_S),
+ Is_Interface_Type => False);
+ end if;
+
Append_To (Clist,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Component_Typ, Loc),
Attribute_Name => Name_Put_Image,
- Expressions => New_List (
- Make_Identifier (Loc, Name_S),
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Selector_Name => New_Occurrence_Of (C, Loc)))));
+ Expressions => New_List (Make_Identifier (Loc, Name_S),
+ Selected_Comp)));
end Append_Component_Attr;
-------------------------------
@@ -1303,105 +1355,20 @@ package body Exp_Put_Image is
New_Occurrence_Of (Sink_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;
-
- -- Local variables
-
- Tag_Node : Node_Id;
-
-- Start of processing for Build_Image_Call
begin
if Is_Class_Wide_Type (U_Type) then
+ Actions := New_List (Sink_Decl);
- -- For interface types we must generate code to displace the pointer
- -- to the object to reference the base of the underlying object.
+ Put_Specific_Type_Name_Qualifier (Loc,
+ Stms => Actions,
+ Tagged_Obj => Image_Prefix,
+ Buffer_Name => New_Occurrence_Of (Sink_Entity, Loc),
+ Is_Interface_Type => Is_Interface (U_Type));
- -- Generate:
- -- To_Tag_Ptr (Image_Prefix'Address).all
-
- -- Note that Image_Prefix'Address is recursively expanded into a
- -- call to Ada.Tags.Base_Address (Image_Prefix'Address).
-
- if Is_Interface (U_Type) then
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Image_Prefix),
- Attribute_Name => Name_Address)));
-
- -- Common case
-
- else
- Tag_Node :=
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Image_Prefix),
- Attribute_Name => Name_Tag);
- end if;
-
- -- 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 (Tag_Node)),
- 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;
+ Append_To (Actions, Put_Im);
+ Append_To (Actions, Result_Decl);
else
Actions := New_List (Sink_Decl, Put_Im, Result_Decl);
end if;
@@ -1485,9 +1452,89 @@ package body Exp_Put_Image is
return E;
elsif Is_Private_Type (Base_Type (E)) and not Is_Private_Type (E) then
return Implementation_Base_Type (E);
+ elsif Is_Mutably_Tagged_CW_Equivalent_Type (E) then
+ return Get_Corresponding_Mutably_Tagged_Type_If_Present (E);
else
return Base_Type (E);
end if;
end Put_Image_Base_Type;
+ --------------------------------------
+ -- Put_Specific_Type_Name_Qualifier --
+ --------------------------------------
+
+ procedure Put_Specific_Type_Name_Qualifier
+ (Loc : Source_Ptr;
+ Stms : List_Id;
+ Tagged_Obj : Node_Id;
+ Buffer_Name : Node_Id;
+ Is_Interface_Type : Boolean)
+ is
+ Tag_Node : Node_Id;
+ begin
+ if Is_Interface_Type then
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Tagged_Obj),
+ Attribute_Name => Name_Address)));
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Tagged_Obj),
+ Attribute_Name => Name_Tag);
+ end if;
+
+ Append_To (Stms,
+ Put_String_Exp_To_Buffer (Loc,
+ String_Exp =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Wide_Wide_Expanded_Name), Loc),
+ Parameter_Associations => New_List (Tag_Node)),
+ Buffer_Name => Buffer_Name,
+ Wide_Wide => True));
+
+ Append_To (Stms,
+ Put_String_Exp_To_Buffer (Loc,
+ String_Exp => Make_String_Literal (Loc, "'"),
+ Buffer_Name => New_Copy_Tree (Buffer_Name)));
+ end Put_Specific_Type_Name_Qualifier;
+
+ ------------------------------
+ -- Put_String_Exp_To_Buffer --
+ ------------------------------
+
+ function Put_String_Exp_To_Buffer
+ (Loc : Source_Ptr;
+ String_Exp : Node_Id;
+ Buffer_Name : 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 => Buffer_Name);
+ 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_To_Buffer;
+
end Exp_Put_Image;
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index 250efd2dc90..5e1c9134fb5 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -29,6 +29,7 @@ with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -101,13 +102,10 @@ package body Exp_Strm is
-- Loc parameter is used as the Sloc of the created entity.
function Stream_Base_Type (E : Entity_Id) return Entity_Id;
- -- Stream attributes work on the basis of the base type except for the
- -- array case. For the array case, we do not go to the base type, but
- -- to the first subtype if it is constrained. This avoids problems with
- -- incorrect conversions in the packed array case. Stream_Base_Type is
- -- exactly this function (returns the base type, unless we have an array
- -- type whose first subtype is constrained, in which case it returns the
- -- first subtype).
+ -- For an array type whose whose first subtype is constrained, return
+ -- the first subtype. For the internal representation type corresponding
+ -- to a mutably tagged type, return the mutably tagged type. Otherwise,
+ -- return the base type. Similar to Exp_Put_Image.Put_Image_Base_Type.
--------------------------------
-- Build_Array_Input_Function --
@@ -1502,6 +1500,7 @@ package body Exp_Strm is
function Make_Field_Attribute (C : Entity_Id) return Node_Id is
Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C));
+ Selected : Node_Id;
TSS_Names : constant array (Name_Input .. Name_Write) of
TSS_Name_Type :=
@@ -1524,15 +1523,23 @@ package body Exp_Strm is
return Make_Null_Statement (Loc);
end if;
+ Selected := Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name => New_Occurrence_Of (C, Loc));
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (C)) then
+ Make_Mutably_Tagged_Conversion
+ (Selected,
+ Typ => Get_Corresponding_Mutably_Tagged_Type_If_Present
+ (Etype (C)));
+ end if;
+
return
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Field_Typ, Loc),
Attribute_Name => Nam,
- Expressions => New_List (
- Make_Identifier (Loc, Name_S),
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Selector_Name => New_Occurrence_Of (C, Loc))));
+ Expressions => New_List (Make_Identifier (Loc, Name_S),
+ Selected));
end Make_Field_Attribute;
---------------------------
@@ -1808,6 +1815,10 @@ package body Exp_Strm is
function Stream_Base_Type (E : Entity_Id) return Entity_Id is
begin
+ if Is_Class_Wide_Equivalent_Type (E) then
+ return Corresponding_Mutably_Tagged_Type (E);
+ end if;
+
if Is_Array_Type (E)
and then Is_First_Subtype (E)
then
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 5354d82bd7d..9fb2030a42b 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6819,7 +6819,7 @@ package body Sem_Ch3 is
-- that the element type is constrained.
if Is_Mutably_Tagged_Type (Element_Type) then
- Set_Component_Type (T,
+ Set_Component_Type (Base_Type (T),
Class_Wide_Equivalent_Type (Element_Type));
elsif not Is_Definite_Subtype (Element_Type) then
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 22a04e3ba9b..018c8a07932 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -5603,6 +5603,10 @@ package body Sem_Ch4 is
if No (Act_Decl) then
Set_Etype (N, Etype (Comp));
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (N)) then
+ Make_Mutably_Tagged_Conversion (N);
+ end if;
+
else
-- If discriminants were present in the component
-- declaration, they have been replaced by the
--
2.43.0
