-------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
- Acc_Type : Entity_Id);
+ Acc_Type : Entity_Id;
+ Sel_Comp : Node_Id := Empty);
-- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
-- controlled parts, add an actual parameter that is a pointer to
-- appropriate finalization list. The finalization list is that of the
-- current scope, except for "new Acc'(F(...))" in which case it's the
-- finalization list of the access type returned by the allocator. Acc_Type
- -- is that type in the allocator case; Empty otherwise.
+ -- is that type in the allocator case; Empty otherwise. If Sel_Comp is
+ -- not Empty, then it denotes a selected component and the finalization
+ -- list is obtained from the _controller list of the prefix object.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
- Acc_Type : Entity_Id)
+ Acc_Type : Entity_Id;
+ Sel_Comp : Node_Id := Empty)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Final_List : Node_Id;
Final_List_Actual : Node_Id;
Final_List_Formal : Node_Id;
+ Is_Ctrl_Result : constant Boolean :=
+ Controlled_Type
+ (Underlying_Type (Etype (Function_Id)));
begin
-- No such extra parameter is needed if there are no controlled parts.
-- must be treated the same as a call to class-wide functions. Both of
-- these situations require that a finalization list be passed.
- if not Controlled_Type (Underlying_Type (Etype (Function_Id)))
+ if not Is_Ctrl_Result
and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
then
return;
Present (Associated_Final_Chain (Base_Type (Acc_Type))))
then
Final_List := Find_Final_List (Acc_Type);
+
+ -- If Sel_Comp is present and the function result is controlled, then
+ -- the finalization list will be obtained from the _controller list of
+ -- the selected component's prefix object.
+
+ elsif Present (Sel_Comp) and then Is_Ctrl_Result then
+ Final_List := Find_Final_List (Current_Scope, Sel_Comp);
+
else
Final_List := Find_Final_List (Current_Scope);
end if;
Low_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
- Attribute_name => Name_First),
+ Attribute_Name => Name_First),
High_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
-- formal subtype are not the same, requiring a check.
-- It is necessary to exclude tagged types because of "downward
- -- conversion" errors and a strange assertion error in namet
- -- from gnatf in bug 1215-001 ???
+ -- conversion" errors.
elsif Is_Access_Type (E_Formal)
and then not Same_Type (E_Formal, Etype (Actual))
-- This procedure handles expansion of function calls and procedure call
-- statements (i.e. it serves as the body for Expand_N_Function_Call and
- -- Expand_N_Procedure_Call_Statement. Processing for calls includes:
+ -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
- -- Replace call to Raise_Exception by Raise_Exception always if possible
+ -- Replace call to Raise_Exception by Raise_Exception_Always if possible
-- Provide values of actuals for all formals in Extra_Formals list
-- Replace "call" to enumeration literal function by literal itself
-- Rewrite call to predefined operator as operator
function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
-- Within an instance, a type derived from a non-tagged formal derived
- -- type inherits from the original parent, not from the actual. This is
- -- tested in 4723-003. The current derivation mechanism has the derived
- -- type inherit from the actual, which is only correct outside of the
- -- instance. If the subprogram is inherited, we test for this particular
- -- case through a convoluted tree traversal before setting the proper
- -- subprogram to be called.
+ -- type inherits from the original parent, not from the actual. The
+ -- current derivation mechanism has the derived type inherit from the
+ -- actual, which is only correct outside of the instance. If the
+ -- subprogram is inherited, we test for this particular case through a
+ -- convoluted tree traversal before setting the proper subprogram to be
+ -- called.
--------------------------
-- Add_Actual_Parameter --
-- Replace call to Raise_Exception by call to Raise_Exception_Always
-- if we can tell that the first parameter cannot possibly be null.
- -- This helps optimization and also generation of warnings.
+ -- This improves efficiency by avoiding a run-time test.
-- We do not do this if Raise_Exception_Always does not exist, which
-- can happen in configurable run time profiles which provide only a
- -- Raise_Exception, which is in fact an unconditional raise anyway.
+ -- Raise_Exception.
if Is_RTE (Subp, RE_Raise_Exception)
and then RTE_Available (RE_Raise_Exception_Always)
if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
and then Present (Controlling_Argument (N))
- and then VM_Target = No_VM
then
- Expand_Dispatching_Call (N);
+ if VM_Target = No_VM then
+ Expand_Dispatching_Call (N);
- -- The following return is worrisome. Is it really OK to
- -- skip all remaining processing in this procedure ???
+ -- The following return is worrisome. Is it really OK to
+ -- skip all remaining processing in this procedure ???
- return;
+ return;
+
+ -- Expansion of a dispatching call results in an indirect call, which
+ -- in turn causes current values to be killed (see Resolve_Call), so
+ -- on VM targets we do the call here to ensure consistent warnings
+ -- between VM and non-VM targets.
+
+ else
+ Kill_Current_Values;
+ end if;
+ end if;
-- Similarly, expand calls to RCI subprograms on which pragma
-- All_Calls_Remote applies. The rewriting will be reanalyzed
-- later. Do this only when the call comes from source since we do
-- not want such a rewriting to occur in expanded code.
- elsif Is_All_Remote_Call (N) then
+ if Is_All_Remote_Call (N) then
Expand_All_Calls_Remote_Subprogram_Call (N);
-- Similarly, do not add extra actuals for an entry call whose entity
end if;
end;
end if;
-
- -- Special processing for Ada 2005 AI-329, which requires a call to
- -- Raise_Exception to raise Constraint_Error if the Exception_Id is
- -- null. Note that we never need to do this in GNAT mode, or if the
- -- parameter to Raise_Exception is a use of Identity, since in these
- -- cases we know that the parameter is never null.
-
- -- Note: We must check that the node has not been inlined. This is
- -- required because under zfp the Raise_Exception subprogram has the
- -- pragma inline_always (and hence the call has been expanded above
- -- into a block containing the code of the subprogram).
-
- if Ada_Version >= Ada_05
- and then not GNAT_Mode
- and then Is_RTE (Subp, RE_Raise_Exception)
- and then Nkind (N) = N_Procedure_Call_Statement
- and then (Nkind (First_Actual (N)) /= N_Attribute_Reference
- or else Attribute_Name (First_Actual (N)) /= Name_Identity)
- then
- declare
- RCE : constant Node_Id :=
- Make_Raise_Constraint_Error (Loc,
- Reason => CE_Null_Exception_Id);
- begin
- Insert_After (N, RCE);
- Analyze (RCE);
- end;
- end if;
end Expand_Call;
--------------------------
Loc : constant Source_Ptr := Sloc (N);
H : constant Node_Id := Handled_Statement_Sequence (N);
Body_Id : Entity_Id;
- Spec_Id : Entity_Id;
Except_H : Node_Id;
- Scop : Entity_Id;
- Dec : Node_Id;
- Next_Op : Node_Id;
L : List_Id;
+ Spec_Id : Entity_Id;
procedure Add_Return (S : List_Id);
-- Append a return statement to the statement sequence S if the last
if Is_Scalar_Type (Etype (F))
and then Ekind (F) = E_Out_Parameter
then
+ Check_Restriction (No_Default_Initialization, F);
+
-- Insert the initialization. We turn off validity checks
-- for this assignment, since we do not want any check on
-- the initial value itself (which may well be invalid).
Insert_Before_And_Analyze (First (L),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (F, Loc),
- Expression => Get_Simple_Init_Val (Etype (F), Loc)),
+ Expression => Get_Simple_Init_Val (Etype (F), N)),
Suppress => Validity_Check);
end if;
end;
end if;
- Scop := Scope (Spec_Id);
-
- -- Add discriminal renamings to protected subprograms. Install new
- -- discriminals for expansion of the next subprogram of this protected
- -- type, if any.
-
- if Is_List_Member (N)
- and then Present (Parent (List_Containing (N)))
- and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
- then
- Add_Discriminal_Declarations
- (Declarations (N), Scop, Name_uObject, Loc);
- Add_Private_Declarations
- (Declarations (N), Scop, Name_uObject, Loc);
-
- -- Associate privals and discriminals with the next protected
- -- operation body to be expanded. These are used to expand references
- -- to private data objects and discriminants, respectively.
-
- Next_Op := Next_Protected_Operation (N);
-
- if Present (Next_Op) then
- Dec := Parent (Base_Type (Scop));
- Set_Privals (Dec, Next_Op, Loc);
- Set_Discriminals (Dec);
- end if;
- end if;
-
-- Clear out statement list for stubbed procedure
if Present (Corresponding_Spec (N)) then
end if;
end if;
+ -- Create a set of discriminals for the next protected subprogram body
+
+ if Is_List_Member (N)
+ and then Present (Parent (List_Containing (N)))
+ and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
+ and then Present (Next_Protected_Operation (N))
+ then
+ Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
+ end if;
+
-- Returns_By_Ref flag is normally set when the subprogram is frozen
-- but subprograms with no specs are not frozen.
Detect_Infinite_Recursion (N, Spec_Id);
end if;
- -- Finally, if we are in Normalize_Scalars mode, then any scalar out
- -- parameters must be initialized to the appropriate default value.
-
- if Ekind (Spec_Id) = E_Procedure and then Normalize_Scalars then
- declare
- Floc : Source_Ptr;
- Formal : Entity_Id;
- Stm : Node_Id;
-
- begin
- Formal := First_Formal (Spec_Id);
- while Present (Formal) loop
- Floc := Sloc (Formal);
-
- if Ekind (Formal) = E_Out_Parameter
- and then Is_Scalar_Type (Etype (Formal))
- then
- Stm :=
- Make_Assignment_Statement (Floc,
- Name => New_Occurrence_Of (Formal, Floc),
- Expression =>
- Get_Simple_Init_Val (Etype (Formal), Floc));
- Prepend (Stm, Declarations (N));
- Analyze (Stm);
- end if;
-
- Next_Formal (Formal);
- end loop;
- end;
- end if;
-
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
Position => DT_Position (Prim),
Address_Node =>
- Unchecked_Convert_To (RTE (RE_Address),
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))),
Loc),
Position => DT_Position (Prim),
Address_Node =>
- Unchecked_Convert_To (RTE (RE_Address),
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- Add_Final_List_Actual_To_Build_In_Place_Call
- (Func_Call, Function_Id, Acc_Type => Empty);
+ -- If Lhs is a selected component, then pass it along so that its prefix
+ -- object will be used as the source of the finalization list.
+
+ if Nkind (Lhs) = N_Selected_Component then
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type => Empty, Sel_Comp => Lhs);
+ else
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type => Empty);
+ end if;
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
type Restriction_Id is
- -- The following cases are checked for consistency in the binder
+ -- The following cases are checked for consistency in the binder. The
+ -- binder will check that every unit either has the restriction set, or
+ -- does not violate the restriction.
(Simple_Barriers, -- GNAT (Ravenscar)
No_Abort_Statements, -- (RM D.7(5), H.4(3))
Static_Priorities, -- GNAT
Static_Storage_Size, -- GNAT
- -- The following cases do not require partition-wide checks
+ -- The following require consistency checking with special rules. See
+ -- individual routines in unit Bcheck for details of what is required.
+
+ No_Default_Initialization, -- GNAT
+
+ -- The following cases do not require consistency checking
Immediate_Reclamation, -- (RM H.4(10))
No_Implementation_Attributes, -- Ada 2005 AI-257
-- The following cases require a parameter value
- -- The following entries are fully checked at compile/bind time,
- -- which means that the compiler can in general tell the minimum
- -- value which could be used with a restrictions pragma. The binder
- -- can deduce the appropriate minimum value for the partition by
- -- taking the maximum value required by any unit.
+ -- The following entries are fully checked at compile/bind time, which
+ -- means that the compiler can in general tell the minimum value which
+ -- could be used with a restrictions pragma. The binder can deduce the
+ -- appropriate minimum value for the partition by taking the maximum
+ -- value required by any unit.
Max_Protected_Entries, -- (RM D.7(14))
Max_Select_Alternatives, -- (RM D.7(12))
Max_Task_Entries, -- (RM D.7(13), H.4(3))
- -- The following entries are also fully checked at compile/bind
- -- time, and the compiler can also at least in some cases tell
- -- the minimum value which could be used with a restriction pragma.
- -- The difference is that the contributions are additive, so the
- -- binder deduces this value by adding the unit contributions.
+ -- The following entries are also fully checked at compile/bind time,
+ -- and the compiler can also at least in some cases tell the minimum
+ -- value which could be used with a restriction pragma. The difference
+ -- is that the contributions are additive, so the binder deduces this
+ -- value by adding the unit contributions.
Max_Tasks, -- (RM D.7(19), H.4(3))
- -- The following entries are checked at compile time only for
- -- zero/nonzero entries. This means that the compiler can tell
- -- at compile time if a restriction value of zero is (would be)
- -- violated, but that is all. The compiler cannot distinguish
- -- between different non-zero values.
+ -- The following entries are checked at compile time only for zero/
+ -- nonzero entries. This means that the compiler can tell at compile
+ -- time if a restriction value of zero is (would be) violated, but that
+ -- the compiler cannot distinguish between different non-zero values.
Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
Max_Entry_Queue_Length, -- GNAT
-- Restriction Status Declarations --
-------------------------------------
- -- The following declarations are used to record the current status
- -- or restrictions (for the current unit, or related units, at compile
- -- time, and for all units in a partition at bind time or run time).
+ -- The following declarations are used to record the current status or
+ -- restrictions (for the current unit, or related units, at compile time,
+ -- and for all units in a partition at bind time or run time).
type Restriction_Flags is array (All_Restrictions) of Boolean;
type Restriction_Values is array (All_Parameter_Restrictions) of Natural;
type Restrictions_Info is record
Set : Restriction_Flags;
- -- An entry is True in the Set array if a restrictions pragma has
- -- been encountered for the given restriction. If the value is
- -- True for a parameter restriction, then the corresponding entry
- -- in the Value array gives the minimum value encountered for any
- -- such restriction.
+ -- An entry is True in the Set array if a restrictions pragma has been
+ -- encountered for the given restriction. If the value is True for a
+ -- parameter restriction, then the corresponding entry in the Value
+ -- array gives the minimum value encountered for any such restriction.
Value : Restriction_Values;
-- If the entry for a parameter restriction in Set is True (i.e. a
-- pragma specifying a value greater than Int'Last is simply ignored.
Violated : Restriction_Flags;
- -- An entry is True in the violations array if the compiler has
- -- detected a violation of the restriction. For a parameter
- -- restriction, the Count and Unknown arrays have additional
- -- information.
+ -- An entry is True in the violations array if the compiler has detected
+ -- a violation of the restriction. For a parameter restriction, the
+ -- Count and Unknown arrays have additional information.
Count : Restriction_Values;
- -- If an entry for a parameter restriction is True in Violated,
- -- the corresponding entry in the Count array may record additional
+ -- If an entry for a parameter restriction is True in Violated, the
+ -- corresponding entry in the Count array may record additional
-- information. If the actual minimum count is known (by taking
-- maximums, or sums, depending on the restriction), it will be
-- recorded in this array. If not, then the value will remain zero.
+ -- The value is also zero for a non-violated restriction.
Unknown : Parameter_Flags;
- -- If an entry for a parameter restriction is True in Violated,
- -- the corresponding entry in the Unknown array may record additional
+ -- If an entry for a parameter restriction is True in Violated, the
+ -- corresponding entry in the Unknown array may record additional
-- information. If the actual count is not known by the compiler (but
- -- is known to be non-zero), then the entry in Unknown will be True.
+ -- is nown to be non-zero), then the entry in Unknown will be True.
-- This indicates that the value in Count is not known to be exact,
-- and the actual violation count may be higher.
OSDN Git Service
