+2012-04-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Process_Declarations): Detect a case where
+ a source object was initialized by another source object,
+ but the expression was rewritten as a class-wide conversion
+ of Ada.Tags.Displace.
+ * exp_util.adb (Initialized_By_Ctrl_Function): Removed.
+ (Is_Controlled_Function_Call): New routine.
+ (Is_Displacement_Of_Ctrl_Function_Result): Removed.
+ (Is_Displacement_Of_Object_Or_Function_Result): New routine.
+ (Is_Source_Object): New routine.
+ (Requires_Cleanup_Actions): Detect a case where a source object was
+ initialized by another source object, but the expression was rewritten
+ as a class-wide conversion of Ada.Tags.Displace.
+ * exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): Removed.
+ (Is_Displacement_Of_Object_Or_Function_Result): New routine.
+
+2012-04-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Call): A call to an expression function
+ does not freeze if it appears in a different scope from the
+ expression function itself. Such calls appear in the generated
+ bodies of other expression functions, or in pre/postconditions
+ of subsequent subprograms.
+
2012-04-02 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb: Code clean up.
Processing_Actions (Has_No_Init => True);
-- Detect a case where a source object has been initialized by
- -- a controlled function call which was later rewritten as a
- -- class-wide conversion of Ada.Tags.Displace.
+ -- a controlled function call or another object which was later
+ -- rewritten as a class-wide conversion of Ada.Tags.Displace.
- -- Obj : Class_Wide_Type := Function_Call (...);
+ -- Obj1 : CW_Type := Src_Obj;
+ -- Obj2 : CW_Type := Function_Call (...);
- -- Temp : ... := Function_Call (...)'reference;
- -- Obj : Class_Wide_Type renames
- -- (... Ada.Tags.Displace (Temp));
+ -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+ -- Tmp : ... := Function_Call (...)'reference;
+ -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
- elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
+ elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
Processing_Actions (Has_No_Init => True);
end if;
return True;
end Is_All_Null_Statements;
- ---------------------------------------------
- -- Is_Displacement_Of_Ctrl_Function_Result --
- ---------------------------------------------
+ --------------------------------------------------
+ -- Is_Displacement_Of_Object_Or_Function_Result --
+ --------------------------------------------------
- function Is_Displacement_Of_Ctrl_Function_Result
+ function Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id : Entity_Id) return Boolean
is
- function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean;
- -- Determine whether object declaration N is initialized by a controlled
- -- function call.
+ function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
+ -- Determine whether a particular node denotes a controlled function
+ -- call.
function Is_Displace_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node is a call to Ada.Tags.Displace.
-- The call might be nested within other actions such as conversions.
- ----------------------------------
- -- Initialized_By_Ctrl_Function --
- ----------------------------------
+ function Is_Source_Object (N : Node_Id) return Boolean;
+ -- Determine whether a particular node denotes a source object
+
+ ---------------------------------
+ -- Is_Controlled_Function_Call --
+ ---------------------------------
- function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is
- Expr : Node_Id := Original_Node (Expression (N));
+ function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
+ Expr : Node_Id := Original_Node (N);
begin
if Nkind (Expr) = N_Function_Call then
Nkind_In (Expr, N_Expanded_Name, N_Identifier)
and then Ekind (Entity (Expr)) = E_Function
and then Needs_Finalization (Etype (Entity (Expr)));
- end Initialized_By_Ctrl_Function;
+ end Is_Controlled_Function_Call;
----------------------
-- Is_Displace_Call --
end loop;
return
- Nkind (Call) = N_Function_Call
+ Present (Call)
+ and then Nkind (Call) = N_Function_Call
and then Is_RTE (Entity (Name (Call)), RE_Displace);
end Is_Displace_Call;
+ ----------------------
+ -- Is_Source_Object --
+ ----------------------
+
+ function Is_Source_Object (N : Node_Id) return Boolean is
+ begin
+ return
+ Present (N)
+ and then Nkind (N) in N_Has_Entity
+ and then Is_Object (Entity (N))
+ and then Comes_From_Source (N);
+ end Is_Source_Object;
+
-- Local variables
Decl : constant Node_Id := Parent (Obj_Id);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
Orig_Decl : constant Node_Id := Original_Node (Decl);
- -- Start of processing for Is_Displacement_Of_Ctrl_Function_Result
+ -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
begin
- -- Detect the following case:
+ -- Case 1:
- -- Obj : Class_Wide_Type := Function_Call (...);
+ -- Obj : CW_Type := Function_Call (...);
- -- which is rewritten into:
+ -- rewritten into:
- -- Temp : ... := Function_Call (...)'reference;
- -- Obj : Class_Wide_Type renames (... Ada.Tags.Displace (Temp));
+ -- Tmp : ... := Function_Call (...)'reference;
+ -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
- -- when the return type of the function and the class-wide type require
+ -- where the return type of the function and the class-wide type require
+ -- dispatch table pointer displacement.
+
+ -- Case 2:
+
+ -- Obj : CW_Type := Src_Obj;
+
+ -- rewritten into:
+
+ -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+
+ -- where the type of the source object and the class-wide type require
-- dispatch table pointer displacement.
return
Nkind (Decl) = N_Object_Renaming_Declaration
and then Nkind (Orig_Decl) = N_Object_Declaration
and then Comes_From_Source (Orig_Decl)
- and then Initialized_By_Ctrl_Function (Orig_Decl)
and then Is_Class_Wide_Type (Obj_Typ)
- and then Is_Displace_Call (Renamed_Object (Obj_Id));
- end Is_Displacement_Of_Ctrl_Function_Result;
+ and then Is_Displace_Call (Renamed_Object (Obj_Id))
+ and then
+ (Is_Controlled_Function_Call (Expression (Orig_Decl))
+ or else Is_Source_Object (Expression (Orig_Decl)));
+ end Is_Displacement_Of_Object_Or_Function_Result;
------------------------------
-- Is_Finalizable_Transient --
then
return True;
- -- Detect a case where a source object has been initialized by a
- -- controlled function call which was later rewritten as a class-
- -- wide conversion of Ada.Tags.Displace.
+ -- Detect a case where a source object has been initialized by
+ -- a controlled function call or another object which was later
+ -- rewritten as a class-wide conversion of Ada.Tags.Displace.
- -- Obj : Class_Wide_Type := Function_Call (...);
+ -- Obj1 : CW_Type := Src_Obj;
+ -- Obj2 : CW_Type := Function_Call (...);
- -- Temp : ... := Function_Call (...)'reference;
- -- Obj : Class_Wide_Type renames
- -- (... Ada.Tags.Displace (Temp));
+ -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+ -- Tmp : ... := Function_Call (...)'reference;
+ -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
- elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
+ elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
return True;
end if;
OSDN Git Service
