------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
Final_List_Actual : Node_Id;
Final_List_Formal : Node_Id;
Is_Ctrl_Result : constant Boolean :=
- Controlled_Type
+ Needs_Finalization
(Underlying_Type (Etype (Function_Id)));
begin
-- No such extra parameter is needed if there are no controlled parts.
- -- The test for Controlled_Type accounts for class-wide results (which
- -- potentially have controlled parts, even if the root type doesn't),
- -- and the test for a tagged result type is needed because calls to
- -- such a function can in general occur in dispatching contexts, which
- -- 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 Is_Ctrl_Result
- and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
- then
+ -- The test for Needs_Finalization accounts for class-wide results
+ -- (which potentially have controlled parts, even if the root type
+ -- doesn't), and the test for a tagged result type is needed because
+ -- calls to such a function can in general occur in dispatching
+ -- contexts, which 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 Needs_BIP_Final_List (Function_Id) then
return;
end if;
Prev := Actual;
Prev_Orig := Original_Node (Prev);
- -- The original actual may have been a call written in prefix
- -- form, and rewritten before analysis.
-
- if not Analyzed (Prev_Orig)
- and then Nkind_In (Actual, N_Function_Call, N_Identifier)
- then
- Prev_Orig := Prev;
- end if;
-
-- Ada 2005 (AI-251): Check if any formal is a class-wide interface
-- to expand it in a further round.
if Ekind (Etype (Prev)) in Private_Kind
and then not Has_Discriminants (Base_Type (Etype (Prev)))
then
- Add_Extra_Actual (
- New_Occurrence_Of (Standard_False, Loc),
- Extra_Constrained (Formal));
+ Add_Extra_Actual
+ (New_Occurrence_Of (Standard_False, Loc),
+ Extra_Constrained (Formal));
elsif Is_Constrained (Etype (Formal))
or else not Has_Discriminants (Etype (Prev))
then
- Add_Extra_Actual (
- New_Occurrence_Of (Standard_True, Loc),
- Extra_Constrained (Formal));
+ Add_Extra_Actual
+ (New_Occurrence_Of (Standard_True, Loc),
+ Extra_Constrained (Formal));
-- Do not produce extra actuals for Unchecked_Union parameters.
-- Jump directly to the end of the loop.
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
- Intval => Scope_Depth (Standard_Standard)),
+ Intval => Scope_Depth (Standard_Standard)),
Extra_Accessibility (Formal));
end if;
end;
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
- Intval => Type_Access_Level (Etype (Prev_Orig))),
+ Intval => Type_Access_Level (Etype (Prev_Orig))),
Extra_Accessibility (Formal));
end if;
- -- All cases other than thunks
+ -- If the actual is an access discriminant, then pass the level
+ -- of the enclosing object (RM05-3.10.2(12.4/2)).
+
+ elsif Nkind (Prev_Orig) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (Prev_Orig))) =
+ E_Discriminant
+ and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
+ E_Anonymous_Access_Type
+ then
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Object_Access_Level (Prefix (Prev_Orig))),
+ Extra_Accessibility (Formal));
+
+ -- All other cases
else
case Nkind (Prev_Orig) is
-- For X'Access, pass on the level of the prefix X
when Attribute_Access =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval =>
- Object_Access_Level (Prefix (Prev_Orig))),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval =>
+ Object_Access_Level (Prefix (Prev_Orig))),
+ Extra_Accessibility (Formal));
-- Treat the unchecked attributes as library-level
when Attribute_Unchecked_Access |
Attribute_Unrestricted_Access =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval => Scope_Depth (Standard_Standard)),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Scope_Depth (Standard_Standard)),
+ Extra_Accessibility (Formal));
-- No other cases of attributes returning access
-- values that can be passed to access parameters
-- current scope level.
when N_Allocator =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Scope_Depth (Current_Scope) + 1),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Scope_Depth (Current_Scope) + 1),
+ Extra_Accessibility (Formal));
- -- For other cases we simply pass the level of the
- -- actual's access type.
+ -- For other cases we simply pass the level of the actual's
+ -- access type. The type is retrieved from Prev rather than
+ -- Prev_Orig, because in some cases Prev_Orig denotes an
+ -- original expression that has not been analyzed.
when others =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval => Type_Access_Level (Etype (Prev_Orig))),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Type_Access_Level (Etype (Prev))),
+ Extra_Accessibility (Formal));
end case;
end if;
-- If the return type is limited the context is an initialization
-- and different processing applies.
- if Controlled_Type (Etype (Subp))
+ if Needs_Finalization (Etype (Subp))
and then not Is_Inherently_Limited_Type (Etype (Subp))
and then not Is_Limited_Interface (Etype (Subp))
then
elsif Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Spec_Id);
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Spec_Id);
end if;
end;
-- which denotes the enclosing protected object. If the enclosing
-- operation is an entry, we are immediately within the protected body,
-- and we can retrieve the object from the service entries procedure. A
- -- barrier function has has the same signature as an entry. A barrier
+ -- barrier function has the same signature as an entry. A barrier
-- function is compiled within the protected object, but unlike
-- protected operations its never needs locks, so that its protected
-- body subprogram points to itself.
begin
if Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Subp);
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Subp);
end if;
end;
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
+ --------------------------
+ -- Needs_BIP_Final_List --
+ --------------------------
+
+ function Needs_BIP_Final_List (E : Entity_Id) return Boolean is
+ pragma Assert (Is_Build_In_Place_Function (E));
+ Result_Subt : constant Entity_Id := Underlying_Type (Etype (E));
+
+ begin
+ -- We need the BIP_Final_List if the result type needs finalization. We
+ -- also need it for tagged types, even if not class-wide, because some
+ -- type extension might need finalization, and all overriding functions
+ -- must have the same calling conventions. However, if there is a
+ -- pragma Restrictions (No_Finalization), we never need this parameter.
+
+ return (Needs_Finalization (Result_Subt)
+ or else Is_Tagged_Type (Underlying_Type (Result_Subt)))
+ and then not Restriction_Active (No_Finalization);
+ end Needs_BIP_Final_List;
+
end Exp_Ch6;
OSDN Git Service
