The patch modifies the expansion of attributes 'Old and 'Update to ensure that the tag of a tagged prefix is not modified as a result attribute evaluation.
------------ -- Source -- ------------ -- types.ads package Types is type Root is tagged record X : Integer; end record; procedure Show (R : Root); type Ext is new Root with record Y : Integer; end record; overriding procedure Show (R : Ext); end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is procedure Show (R : Root) is begin Put_Line ("(root) X =" & R.X'Img); end Show; overriding procedure Show (R : Ext) is begin Put_Line ("(ext) X =" & R.X'Img); Put_Line ("(ext) Y =" & R.Y'Img); end Show; end Types; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is procedure Show_Me (R : Root) is Tmp : Root'Class := R; begin Show (Tmp); end Show_Me; procedure Wibble (R : Root) is begin Show_Me (R); Show_Me (R'Update (X => 5)); end Wibble; A : Ext; begin A.X := 0; A.Y := 1; Wibble (Root (A)); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ ./main (ext) X = 0 (ext) Y = 1 (ext) X = 5 (ext) Y = 1 Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Hristian Kirtchev <kirtc...@adacore.com> * exp_attr.adb (Expand_N_Attribute_Reference, Expand_Update_Attribute): Preserve the tag of a prefix by offering a specific view of the class-wide version of the prefix.
Index: exp_attr.adb =================================================================== --- exp_attr.adb (revision 217828) +++ exp_attr.adb (working copy) @@ -1021,6 +1021,9 @@ Pref : constant Node_Id := Prefix (N); Typ : constant Entity_Id := Etype (Pref); Blk : Node_Id; + CW_Decl : Node_Id; + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; Decls : List_Id; Installed : Boolean; Loc : Source_Ptr; @@ -1338,19 +1341,56 @@ -- Step 3: Create a constant to capture the value of the prefix at the -- entry point into the loop. - -- Generate: - -- Temp : constant <type of Pref> := <Pref>; - Temp_Id := Make_Temporary (Loc, 'P'); - Temp_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Pref)); - Append_To (Decls, Temp_Decl); + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. + if Is_Tagged_Type (Typ) then + + -- Generate: + -- CW_Temp : constant Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + CW_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref))); + Append_To (Decls, CW_Decl); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Temp_Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp_Id, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))); + Append_To (Decls, Temp_Decl); + + -- Non-tagged case + + else + CW_Decl := Empty; + + -- Generate: + -- Temp : constant Typ := Pref; + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref)); + Append_To (Decls, Temp_Decl); + end if; + -- Step 4: Analyze all bits Installed := Current_Scope = Scope (Loop_Id); @@ -1374,6 +1414,10 @@ -- the declaration of the constant. else + if Present (CW_Decl) then + Analyze (CW_Decl); + end if; + Analyze (Temp_Decl); end if; @@ -4358,19 +4402,13 @@ --------- when Attribute_Old => Old : declare - Asn_Stm : Node_Id; + Typ : constant Entity_Id := Etype (N); + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; Subp : Node_Id; Temp : Entity_Id; begin - Temp := Make_Temporary (Loc, 'T', Pref); - - -- Set the entity kind now in order to mark the temporary as a - -- handler of attribute 'Old's prefix. - - Set_Ekind (Temp, E_Constant); - Set_Stores_Attribute_Old_Prefix (Temp); - -- Climb the parent chain looking for subprogram _Postconditions Subp := N; @@ -4395,28 +4433,63 @@ pragma Assert (Present (Subp)); - -- Generate: - -- Temp : constant <Pref type> := <Pref>; + Temp := Make_Temporary (Loc, 'T', Pref); - Asn_Stm := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Etype (N), Loc), - Expression => Pref); + -- Set the entity kind now in order to mark the temporary as a + -- handler of attribute 'Old's prefix. + Set_Ekind (Temp, E_Constant); + Set_Stores_Attribute_Old_Prefix (Temp); + -- Push the scope of the related subprogram where _Postcondition -- resides as this ensures that the object will be analyzed in the -- proper context. Push_Scope (Scope (Defining_Entity (Subp))); - -- The object declaration is inserted before the body of subprogram - -- _Postconditions. This ensures that any precondition-like actions - -- are still executed before any parameter values are captured and - -- the multiple 'Old occurrences appear in order of declaration. + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. - Insert_Before_And_Analyze (Subp, Asn_Stm); + if Is_Tagged_Type (Typ) then + + -- Generate: + -- CW_Temp : constant Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + Insert_Before_And_Analyze (Subp, + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref)))); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Insert_Before_And_Analyze (Subp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); + + -- Non-tagged case + + else + -- Generate: + -- Temp : constant Typ := Pref; + + Insert_Before_And_Analyze (Subp, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref))); + end if; + Pop_Scope; -- Ensure that the prefix of attribute 'Old is valid. The check must @@ -7351,31 +7424,66 @@ -- Local variables - Aggr : constant Node_Id := First (Expressions (N)); - Loc : constant Source_Ptr := Sloc (N); - Pref : constant Node_Id := Prefix (N); - Typ : constant Entity_Id := Etype (Pref); - Assoc : Node_Id; - Comp : Node_Id; - Expr : Node_Id; - Temp : Entity_Id; + Aggr : constant Node_Id := First (Expressions (N)); + Loc : constant Source_Ptr := Sloc (N); + Pref : constant Node_Id := Prefix (N); + Typ : constant Entity_Id := Etype (Pref); + Assoc : Node_Id; + Comp : Node_Id; + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; + Expr : Node_Id; + Temp : Entity_Id; -- Start of processing for Expand_Update_Attribute begin - -- Create the anonymous object that stores the value of the prefix and - -- reflects subsequent changes in value. Generate: + -- Create the anonymous object to store the value of the prefix and + -- capture subsequent changes in value. - -- Temp : <type of Pref> := Pref; + Temp := Make_Temporary (Loc, 'T', Pref); - Temp := Make_Temporary (Loc, 'T'); + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Pref))); + if Is_Tagged_Type (Typ) then + -- Generate: + -- CW_Temp : Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref)))); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); + + -- Non-tagged case + + else + -- Generate: + -- Temp : Typ := Pref; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref))); + end if; + -- Process the update aggregate Assoc := First (Component_Associations (Aggr));