+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
end;
end if;
- Apply_Accessibility_Check (Temp);
-
-- Generate the tag assignment
-- Suppress the tag assignment for VM targets because VM tags are
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,
+ 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;
- -- An unchecked conversion is needed in the classwide case
- -- because the designated type can be an ancestor of the
- -- subtype mark of the allocator.
+ -- Note: the accessibility check must be inserted after the call to
+ -- [Deep_]Adjust to ensure proper completion of the assignment.
- Make_Adjust_Call
- (Obj_Ref =>
- Unchecked_Convert_To (T,
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Temp, Loc))),
- Typ => T));
- end if;
- end if;
+ Apply_Accessibility_Check (Temp);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
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.
-
- if Nkind_In (N, N_Identifier,
- N_Object_Renaming_Declaration)
- and then Original_Node (N) /= N
- then
- Detect_Subprogram_Call (Original_Node (N));
+ -- A regular procedure or function call
+
+ if Nkind (N) in N_Subprogram_Call then
+ Must_Hook := True;
+ return Abandon;
+
+ -- Special cases
- -- The original construct contains a subprogram call, there is
- -- no point in continuing the tree traversal.
+ -- 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));
if Must_Hook then
return Abandon;
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
-- 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);
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 --
-----------------------
-- 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;
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 --
-------------
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 --
----------------
-- 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,
-- 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
projects / gcc.git / commitdiff