[multiple changes]
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com> * 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 <kirtchev@adacore.com> * 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 <miranda@adacore.com> * exp_unst.ads, exp_unst.adb (Get_Level, Subp_Index): Moved to library level. From-SVN: r235258
This commit is contained in:
Arnaud Charlet
parent
dfbc6cbe30
commit
18431dc503
6 changed files with 102 additions and 92 deletions
|
|
@ -1,3 +1,20 @@
|
|||
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* 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 <kirtchev@adacore.com>
|
||||
|
||||
* 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 <miranda@adacore.com>
|
||||
|
||||
* exp_unst.ads, exp_unst.adb (Get_Level, Subp_Index): Moved to library
|
||||
level.
|
||||
|
||||
2016-04-20 Arnaud Charlet <charlet@adacore.com>
|
||||
|
||||
* sem_ch9.adb (Analyze_Task_Type_Declaration): Shut down warning
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -862,16 +862,16 @@ package body Exp_Prag is
|
|||
|
||||
-- Generate a temporary to capture the value of the prefix:
|
||||
-- Temp : <Pref type>;
|
||||
-- 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);
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue