===================================================================
@@ -578,11 +578,13 @@
--------------------------
procedure Check_Address_Clause (E : Entity_Id) is
- Addr : constant Node_Id := Address_Clause (E);
- Expr : Node_Id;
- Decl : constant Node_Id := Declaration_Node (E);
- Loc : constant Source_Ptr := Sloc (Decl);
- Typ : constant Entity_Id := Etype (E);
+ Addr : constant Node_Id := Address_Clause (E);
+ Expr : Node_Id;
+ Decl : constant Node_Id := Declaration_Node (E);
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Typ : constant Entity_Id := Etype (E);
+ Lhs : Node_Id;
+ Tag_Assign : Node_Id;
begin
if Present (Addr) then
@@ -636,9 +638,13 @@
if Present (Expression (Decl)) then
- -- Capture initialization value at point of declaration
+ -- Capture initialization value at point of declaration,
+ -- and make explicit assignment legal, because object may
+ -- be a constant.
Remove_Side_Effects (Expression (Decl));
+ Lhs := New_Occurrence_Of (E, Loc);
+ Set_Assignment_OK (Lhs);
-- Move initialization to freeze actions (once the object has
-- been frozen, and the address clause alignment check has been
@@ -646,10 +652,19 @@
Append_Freeze_Action (E,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (E, Loc),
+ Name => Lhs,
Expression => Expression (Decl)));
Set_No_Initialization (Decl);
+
+ -- If the objet is tagged, check whether the tag must be
+ -- reassigned expliitly.
+
+ Tag_Assign := Make_Tag_Assignment (Decl);
+ if Present (Tag_Assign) then
+ Append_Freeze_Action (E, Tag_Assign);
+ end if;
+
end if;
end if;
end Check_Address_Clause;
===================================================================
@@ -418,6 +418,20 @@
Apply_Address_Clause_Check (E, N);
end if;
+ -- Analyze actions in freeze node, if any.
+
+ if Present (Actions (N)) then
+ declare
+ Act : Node_Id;
+ begin
+ Act := First (Actions (N));
+ while Present (Act) loop
+ Analyze (Act);
+ Next (Act);
+ end loop;
+ end;
+ end if;
+
-- If initialization statements have been captured in a compound
-- statement, insert them back into the tree now.
@@ -566,7 +580,7 @@
-- If subprogram, freeze the subprogram
elsif Is_Subprogram (E) then
- Freeze_Subprogram (N);
+ Exp_Ch6.Freeze_Subprogram (N);
-- Ada 2005 (AI-251): Remove the freezing node associated with the
-- entities internally used by the frontend to register primitives
===================================================================
@@ -5328,7 +5328,6 @@
Next_N : constant Node_Id := Next (N);
Id_Ref : Node_Id;
- New_Ref : Node_Id;
Init_After : Node_Id := N;
-- Node after which the initialization actions are to be inserted. This
@@ -5336,6 +5335,8 @@
-- which case the init proc call must be inserted only after the bodies
-- of the shared variable procedures have been seen.
+ Tag_Assign : Node_Id;
+
-- Start of processing for Expand_N_Object_Declaration
begin
@@ -5825,52 +5826,21 @@
-- CPP_CLASS, and for initializations that are aggregates, because
-- they have to have the right tag.
- if Is_Tagged_Type (Typ)
- and then not Is_Class_Wide_Type (Typ)
- and then not Is_CPP_Class (Typ)
- and then Tagged_Type_Expansion
- and then Nkind (Expr) /= N_Aggregate
- and then (Nkind (Expr) /= N_Qualified_Expression
- or else Nkind (Expression (Expr)) /= N_Aggregate)
- then
- declare
- Full_Typ : constant Entity_Id := Underlying_Type (Typ);
- Tag_Assign : Node_Id;
+ -- The re-assignment of the tag has to be done even if the object
+ -- is a constant. The assignment must be analyzed after the
+ -- declaration. If an address clause follows, this is handled as
+ -- part of the freeze actions for the object, otherwise insert
+ -- tag assignment here.
- begin
- -- The re-assignment of the tag has to be done even if the
- -- object is a constant. The assignment must be analyzed
- -- after the declaration.
+ Tag_Assign := Make_Tag_Assignment (N);
- New_Ref :=
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Def_Id, Loc),
- Selector_Name =>
- New_Occurrence_Of (First_Tag_Component (Full_Typ),
- Loc));
- Set_Assignment_OK (New_Ref);
+ if Present (Tag_Assign) then
+ if Present (Following_Address_Clause (N)) then
+ Ensure_Freeze_Node (Def_Id);
- Tag_Assign :=
- Make_Assignment_Statement (Loc,
- Name => New_Ref,
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node
- (First_Elmt (Access_Disp_Table (Full_Typ))),
- Loc)));
-
- -- Tag initialization cannot be done before object is
- -- frozen. If an address clause follows, make sure freeze
- -- node exists, and insert it and the tag assignment after
- -- the address clause.
-
- if Present (Following_Address_Clause (N)) then
- Init_After := Following_Address_Clause (N);
- end if;
-
+ else
Insert_Action_After (Init_After, Tag_Assign);
- end;
+ end if;
-- Handle C++ constructor calls. Note that we do not check that
-- Typ is a tagged type since the equivalent Ada type of a C++
@@ -9717,6 +9687,46 @@
Predef_List := Res;
end Make_Predefined_Primitive_Specs;
+ -------------------------
+ -- Make_Tag_Assignment --
+ -------------------------
+
+ function Make_Tag_Assignment (N : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_If : constant Entity_Id := Defining_Identifier (N);
+ Expr : constant Node_Id := Expression (N);
+ Typ : constant Entity_Id := Etype (Def_If);
+ Full_Typ : constant Entity_Id := Underlying_Type (Typ);
+ New_Ref : Node_Id;
+
+ begin
+ if Is_Tagged_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ and then not Is_CPP_Class (Typ)
+ and then Tagged_Type_Expansion
+ and then Nkind (Expr) /= N_Aggregate
+ and then (Nkind (Expr) /= N_Qualified_Expression
+ or else Nkind (Expression (Expr)) /= N_Aggregate)
+ then
+ New_Ref :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Def_If, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
+ Set_Assignment_OK (New_Ref);
+
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Ref,
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of (Node
+ (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
+ else
+ return Empty;
+ end if;
+ end Make_Tag_Assignment;
+
---------------------------------
-- Needs_Simple_Initialization --
---------------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -104,6 +104,14 @@
-- then tags components located at variable positions of Target are
-- initialized.
+ function Make_Tag_Assignment (N : Node_Id) return Node_Id;
+ -- An object declaration that has an initialization for a tagged object
+ -- requires a separate reassignment of the tag of the given type, because
+ -- the expression may include an unchecked conversion. This tag
+ -- assignment is inserted after the declaration, but if the object has
+ -- an address clause the assignment is handled as part of the freezing
+ -- of the object, see Check_Address_Clause.
+
function Needs_Simple_Initialization
(T : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
When a tagged object is initialized in a declaration, the expression may involve a view conversion, so the tag must be re-assigned explicitly to the object in a separate step. This assignment can only take place after the object is frozen. If there is an address clause for the object following the declaration, the tag assignment must appear as part of the freeze qctions for the object, and these actions must be properly analyzed. The following must compile quietly: --- with System; package body P is procedure Dummy is begin null; end; procedure Proc (Value : T; Value_Address : System.Address; Value_Access : out T_Access) is Local : aliased T := Value; for Local'Address use Value_Address; begin Value_Access := Local'Unchecked_Access; end; end P; --- package P is type T is tagged null record; type T_Access is access all T; procedure Dummy; end P; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-31 Ed Schonberg <schonberg@adacore.com> * exp_ch3.ads (Make_Tag_Assignment): New function, used to re-initialize the tag in a tagged object declaration with initial value. * exp_ch3.adb (Expand_N_Object_Declaration): Use Make_Tag_Assignment to simplify code for a tagged object declaration. * exp_ch13.adb (Expand_Freeze_Entity): Analyze freeze actions for the freeze node of an object. * freeze.adb (Check_Address_Clause): Use Make_Tag_Assignment when needed to extend Freeze_Actions for a tagged object declaration.