diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 25 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 95 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 13 |
5 files changed, 113 insertions, 44 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 904c9cc..f42c041 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +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. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 525bae7..f8730f3 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1917,16 +1917,17 @@ package body Exp_Ch7 is 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; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 335ba10..b43bd16 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3940,27 +3940,30 @@ package body Exp_Util is 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 @@ -3977,7 +3980,7 @@ package body Exp_Util is 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 -- @@ -4004,39 +4007,66 @@ package body Exp_Util is 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 -- @@ -7189,17 +7219,18 @@ package body Exp_Util is 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; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 535a4ff..9f3ae2a 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -521,11 +521,12 @@ package Exp_Util is -- False otherwise. True for an empty list. It is an error to call this -- routine with No_List as the argument. - function Is_Displacement_Of_Ctrl_Function_Result + function Is_Displacement_Of_Object_Or_Function_Result (Obj_Id : Entity_Id) return Boolean; - -- Determine whether Obj_Id is a source object that has been initialized by - -- a controlled function call later rewritten as a class-wide conversion of - -- Ada.Tags.Displace. + -- Determine whether Obj_Id is a source entity that has been initialized by + -- either a controlled function call or the assignment of another source + -- object. In both cases the initialization expression is rewritten as a + -- class-wide conversion of Ada.Tags.Displace. function Is_Finalizable_Transient (Decl : Node_Id; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 46a8b19..fc95bb8 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5316,7 +5316,18 @@ package body Sem_Res is -- needs extending because we can generate procedure calls that need -- freezing. - if Is_Entity_Name (Subp) and then not In_Spec_Expression then + -- In Ada 2012, expression functions may be called within pre/post + -- conditions of subsequent functions or expression functions. Such + -- calls do not freeze when they appear within generated bodies, which + -- would place the freeze node in the wrong scope. An expression + -- function is frozen in the usual fashion, by the appearance of a real + -- body, or at the end of a declarative part. + + if Is_Entity_Name (Subp) and then not In_Spec_Expression + and then + (not Is_Expression_Function (Entity (Subp)) + or else Scope (Entity (Subp)) = Current_Scope) + then Freeze_Expression (Subp); end if; |