diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b516cbc642d..f6f5dc34e79 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2016-04-20 Hristian Kirtchev + + * exp_ch4.adb (Expand_Allocator_Expression): Ensure that the + tag assignment and adjustment preceed the accessibility check. + * exp_ch7.adb (Is_Subprogram_Call): Reimplemented. + +2016-04-20 Hristian Kirtchev + + * exp_prag.adb (Expand_Attributes): Ensure that + the temporary used to capture the value of attribute 'Old's + prefix is properly initialized. + +2016-04-20 Javier Miranda + + * exp_unst.ads, exp_unst.adb (Get_Level, Subp_Index): Moved to library + level. + 2016-04-20 Arnaud Charlet * sem_ch9.adb (Analyze_Task_Type_Declaration): Shut down warning diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 190664071a3..7ac80187bd3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1182,8 +1182,6 @@ package body Exp_Ch4 is end; end if; - Apply_Accessibility_Check (Temp); - -- Generate the tag assignment -- Suppress the tag assignment for VM targets because VM tags are @@ -1241,35 +1239,37 @@ package body Exp_Ch4 is Insert_Action (N, Tag_Assign); end if; - if Needs_Finalization (DesigT) and then Needs_Finalization (T) then + -- Generate an Adjust call if the object will be moved. In Ada 2005, + -- the object may be inherently limited, in which case there is no + -- Adjust procedure, and the object is built in place. In Ada 95, the + -- object can be limited but not inherently limited if this allocator + -- came from a return statement (we're allocating the result on the + -- secondary stack). In that case, the object will be moved, so we do + -- want to Adjust. - -- Generate an Adjust call if the object will be moved. In Ada - -- 2005, the object may be inherently limited, in which case - -- there is no Adjust procedure, and the object is built in - -- place. In Ada 95, the object can be limited but not - -- inherently limited if this allocator came from a return - -- statement (we're allocating the result on the secondary - -- stack). In that case, the object will be moved, so we _do_ - -- want to Adjust. + if Needs_Finalization (DesigT) + and then Needs_Finalization (T) + and then not Aggr_In_Place + and then not Is_Limited_View (T) + then + -- An unchecked conversion is needed in the classwide case because + -- the designated type can be an ancestor of the subtype mark of + -- the allocator. - if not Aggr_In_Place - and then not Is_Limited_View (T) - then - Insert_Action (N, - - -- An unchecked conversion is needed in the classwide case - -- because the designated type can be an ancestor of the - -- subtype mark of the allocator. - - Make_Adjust_Call - (Obj_Ref => - Unchecked_Convert_To (T, - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Temp, Loc))), - Typ => T)); - end if; + Insert_Action (N, + Make_Adjust_Call + (Obj_Ref => + Unchecked_Convert_To (T, + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc))), + Typ => T)); end if; + -- Note: the accessibility check must be inserted after the call to + -- [Deep_]Adjust to ensure proper completion of the assignment. + + Apply_Accessibility_Check (Temp); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, PtrT); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index daa5f91c668..60ea45b97d3 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4640,42 +4640,35 @@ package body Exp_Ch7 is function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is begin - -- Complex constructs are factored out by the expander and their - -- occurrences are replaced with references to temporaries or - -- object renamings. Due to this expansion activity, inspect the - -- original tree to detect subprogram calls. + -- A regular procedure or function call - if Nkind_In (N, N_Identifier, - N_Object_Renaming_Declaration) - and then Original_Node (N) /= N - then + if Nkind (N) in N_Subprogram_Call then + Must_Hook := True; + return Abandon; + + -- Special cases + + -- Heavy expansion may relocate function calls outside the related + -- node. Inspect the original node to detect the initial placement + -- of the call. + + elsif Original_Node (N) /= N then Detect_Subprogram_Call (Original_Node (N)); - -- The original construct contains a subprogram call, there is - -- no point in continuing the tree traversal. - if Must_Hook then return Abandon; else return OK; end if; - -- The original construct contains a subprogram call, there is no - -- point in continuing the tree traversal. + -- Generalized indexing always involves a function call - elsif Nkind (N) = N_Object_Declaration - and then Present (Expression (N)) - and then Nkind (Original_Node (Expression (N))) = N_Function_Call + elsif Nkind (N) = N_Indexed_Component + and then Present (Generalized_Indexing (N)) then Must_Hook := True; return Abandon; - -- A regular procedure or function call - - elsif Nkind (N) in N_Subprogram_Call then - Must_Hook := True; - return Abandon; - -- Keep searching else diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 62aa80da005..5df49eef1f5 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -862,16 +862,16 @@ package body Exp_Prag is -- Generate a temporary to capture the value of the prefix: -- Temp : ; - -- Place that temporary at the beginning of declarations, to - -- prevent anomalies in the GNATprove flow-analysis pass in - -- the precondition procedure that follows. Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Etype (Pref), Loc)); - Set_No_Initialization (Decl); + + -- Place that temporary at the beginning of declarations, to + -- prevent anomalies in the GNATprove flow-analysis pass in + -- the precondition procedure that follows. Prepend_To (Decls, Decl); Analyze (Decl); diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index c0a34054eed..668f5969153 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -138,6 +138,36 @@ package body Exp_Unst is Calls.Append (Call); end Append_Unique_Call; + --------------- + -- Get_Level -- + --------------- + + function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is + Lev : Nat; + S : Entity_Id; + begin + Lev := 1; + S := Sub; + loop + if S = Subp then + return Lev; + else + S := Enclosing_Subprogram (S); + Lev := Lev + 1; + end if; + end loop; + end Get_Level; + + ---------------- + -- Subp_Index -- + ---------------- + + function Subp_Index (Sub : Entity_Id) return SI_Type is + begin + pragma Assert (Is_Subprogram (Sub)); + return SI_Type (UI_To_Int (Subps_Index (Sub))); + end Subp_Index; + ----------------------- -- Unnest_Subprogram -- ----------------------- @@ -151,17 +181,9 @@ package body Exp_Unst is -- This function returns the index of the enclosing subprogram which -- will have a Lev value one less than this. - function Get_Level (Sub : Entity_Id) return Nat; - -- Sub is either Subp itself, or a subprogram nested within Subp. This - -- function returns the level of nesting (Subp = 1, subprograms that - -- are immediately nested within Subp = 2, etc). - function Img_Pos (N : Pos) return String; -- Return image of N without leading blank - function Subp_Index (Sub : Entity_Id) return SI_Type; - -- Given the entity for a subprogram, return corresponding Subps index - function Upref_Name (Ent : Entity_Id; Index : Pos; @@ -196,26 +218,6 @@ package body Exp_Unst is return Ret; end Enclosing_Subp; - --------------- - -- Get_Level -- - --------------- - - function Get_Level (Sub : Entity_Id) return Nat is - Lev : Nat; - S : Entity_Id; - begin - Lev := 1; - S := Sub; - loop - if S = Subp then - return Lev; - else - S := Enclosing_Subprogram (S); - Lev := Lev + 1; - end if; - end loop; - end Get_Level; - ------------- -- Img_Pos -- ------------- @@ -237,16 +239,6 @@ package body Exp_Unst is return Buf (Ptr + 1 .. Buf'Last); end Img_Pos; - ---------------- - -- Subp_Index -- - ---------------- - - function Subp_Index (Sub : Entity_Id) return SI_Type is - begin - pragma Assert (Is_Subprogram (Sub)); - return SI_Type (UI_To_Int (Subps_Index (Sub))); - end Subp_Index; - ---------------- -- Upref_Name -- ---------------- @@ -561,7 +553,7 @@ package body Exp_Unst is -- Make new entry in subprogram table if not already made declare - L : constant Nat := Get_Level (Ent); + L : constant Nat := Get_Level (Subp, Ent); begin Subps.Append ((Ent => Ent, diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 084e904b677..d455175ca14 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -678,6 +678,14 @@ package Exp_Unst is -- Subprograms -- ----------------- + function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat; + -- Sub is either Subp itself, or a subprogram nested within Subp. This + -- function returns the level of nesting (Subp = 1, subprograms that + -- are immediately nested within Subp = 2, etc). + + function Subp_Index (Sub : Entity_Id) return SI_Type; + -- Given the entity for a subprogram, return corresponding Subps index + procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id); -- Subp is a library level subprogram which has nested subprograms, and -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure